diff --git a/PBot/AntiFlood.pm b/PBot/AntiFlood.pm index acfebf07..c609fddb 100644 --- a/PBot/AntiFlood.pm +++ b/PBot/AntiFlood.pm @@ -26,1040 +26,1060 @@ use POSIX qw/strftime/; use Text::CSV; sub initialize { - my ($self, %conf) = @_; + my ($self, %conf) = @_; - # flags for 'validated' field - $self->{NICKSERV_VALIDATED} = (1<<0); - $self->{NEEDS_CHECKBAN} = (1<<1); + # flags for 'validated' field + $self->{NICKSERV_VALIDATED} = (1 << 0); + $self->{NEEDS_CHECKBAN} = (1 << 1); - $self->{channels} = {}; # per-channel statistics, e.g. for optimized tracking of last spoken nick for enter-abuse detection, etc - $self->{nickflood} = {}; # statistics to track nickchange flooding - $self->{whois_pending} = {}; # prevents multiple whois for nick joining multiple channels at once - $self->{changinghost} = {}; # tracks nicks changing hosts/identifying to strongly link them + $self->{channels} = {}; # per-channel statistics, e.g. for optimized tracking of last spoken nick for enter-abuse detection, etc + $self->{nickflood} = {}; # statistics to track nickchange flooding + $self->{whois_pending} = {}; # prevents multiple whois for nick joining multiple channels at once + $self->{changinghost} = {}; # tracks nicks changing hosts/identifying to strongly link them - my $filename = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/ban-exemptions'; - $self->{'ban-exemptions'} = PBot::DualIndexHashObject->new(name => 'Ban exemptions', filename => $filename, pbot => $self->{pbot}); - $self->{'ban-exemptions'}->load; + my $filename = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/ban-exemptions'; + $self->{'ban-exemptions'} = PBot::DualIndexHashObject->new(name => 'Ban exemptions', filename => $filename, pbot => $self->{pbot}); + $self->{'ban-exemptions'}->load; - $self->{pbot}->{timer}->register(sub { $self->adjust_offenses }, 60 * 60 * 1); + $self->{pbot}->{timer}->register(sub { $self->adjust_offenses }, 60 * 60 * 1); - $self->{pbot}->{registry}->add_default('text', 'antiflood', 'enforce', $conf{enforce_antiflood} // 1); + $self->{pbot}->{registry}->add_default('text', 'antiflood', 'enforce', $conf{enforce_antiflood} // 1); - $self->{pbot}->{registry}->add_default('text', 'antiflood', 'join_flood_threshold', $conf{join_flood_threshold} // 4); - $self->{pbot}->{registry}->add_default('text', 'antiflood', 'join_flood_time_threshold', $conf{join_flood_time_threshold} // 60 * 30); - $self->{pbot}->{registry}->add_default('array', 'antiflood', 'join_flood_punishment', $conf{join_flood_punishment} // '28800,3600,86400,604800,2419200,14515200'); + $self->{pbot}->{registry}->add_default('text', 'antiflood', 'join_flood_threshold', $conf{join_flood_threshold} // 4); + $self->{pbot}->{registry}->add_default('text', 'antiflood', 'join_flood_time_threshold', $conf{join_flood_time_threshold} // 60 * 30); + $self->{pbot}->{registry}->add_default('array', 'antiflood', 'join_flood_punishment', $conf{join_flood_punishment} // '28800,3600,86400,604800,2419200,14515200'); - $self->{pbot}->{registry}->add_default('text', 'antiflood', 'chat_flood_threshold', $conf{chat_flood_threshold} // 4); - $self->{pbot}->{registry}->add_default('text', 'antiflood', 'chat_flood_time_threshold', $conf{chat_flood_time_threshold} // 10); - $self->{pbot}->{registry}->add_default('array', 'antiflood', 'chat_flood_punishment', $conf{chat_flood_punishment} // '60,300,3600,86400,604800,2419200'); + $self->{pbot}->{registry}->add_default('text', 'antiflood', 'chat_flood_threshold', $conf{chat_flood_threshold} // 4); + $self->{pbot}->{registry}->add_default('text', 'antiflood', 'chat_flood_time_threshold', $conf{chat_flood_time_threshold} // 10); + $self->{pbot}->{registry}->add_default('array', 'antiflood', 'chat_flood_punishment', $conf{chat_flood_punishment} // '60,300,3600,86400,604800,2419200'); - $self->{pbot}->{registry}->add_default('text', 'antiflood', 'nick_flood_threshold', $conf{nick_flood_threshold} // 3); - $self->{pbot}->{registry}->add_default('text', 'antiflood', 'nick_flood_time_threshold', $conf{nick_flood_time_threshold} // 60 * 30); - $self->{pbot}->{registry}->add_default('array', 'antiflood', 'nick_flood_punishment', $conf{nick_flood_punishment} // '60,300,3600,86400,604800,2419200'); + $self->{pbot}->{registry}->add_default('text', 'antiflood', 'nick_flood_threshold', $conf{nick_flood_threshold} // 3); + $self->{pbot}->{registry}->add_default('text', 'antiflood', 'nick_flood_time_threshold', $conf{nick_flood_time_threshold} // 60 * 30); + $self->{pbot}->{registry}->add_default('array', 'antiflood', 'nick_flood_punishment', $conf{nick_flood_punishment} // '60,300,3600,86400,604800,2419200'); - $self->{pbot}->{registry}->add_default('text', 'antiflood', 'enter_abuse_threshold', $conf{enter_abuse_threshold} // 4); - $self->{pbot}->{registry}->add_default('text', 'antiflood', 'enter_abuse_time_threshold', $conf{enter_abuse_time_threshold} // 20); - $self->{pbot}->{registry}->add_default('array', 'antiflood', 'enter_abuse_punishment', $conf{enter_abuse_punishment} // '60,300,3600,86400,604800,2419200'); - $self->{pbot}->{registry}->add_default('text', 'antiflood', 'enter_abuse_max_offenses', $conf{enter_abuse_max_offenses} // 3); + $self->{pbot}->{registry}->add_default('text', 'antiflood', 'enter_abuse_threshold', $conf{enter_abuse_threshold} // 4); + $self->{pbot}->{registry}->add_default('text', 'antiflood', 'enter_abuse_time_threshold', $conf{enter_abuse_time_threshold} // 20); + $self->{pbot}->{registry}->add_default('array', 'antiflood', 'enter_abuse_punishment', $conf{enter_abuse_punishment} // '60,300,3600,86400,604800,2419200'); + $self->{pbot}->{registry}->add_default('text', 'antiflood', 'enter_abuse_max_offenses', $conf{enter_abuse_max_offenses} // 3); - $self->{pbot}->{registry}->add_default('text', 'antiflood', 'debug_checkban', $conf{debug_checkban} // 0); + $self->{pbot}->{registry}->add_default('text', 'antiflood', 'debug_checkban', $conf{debug_checkban} // 0); - $self->{pbot}->{commands}->register(sub { $self->unbanme(@_) }, "unbanme", 0); - $self->{pbot}->{commands}->register(sub { $self->ban_exempt(@_) }, "ban-exempt", 1); - $self->{pbot}->{capabilities}->add('admin', 'can-ban-exempt', 1); + $self->{pbot}->{commands}->register(sub { $self->unbanme(@_) }, "unbanme", 0); + $self->{pbot}->{commands}->register(sub { $self->ban_exempt(@_) }, "ban-exempt", 1); + $self->{pbot}->{capabilities}->add('admin', 'can-ban-exempt', 1); - $self->{pbot}->{event_dispatcher}->register_handler('irc.whoisaccount', sub { $self->on_whoisaccount(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.whoisuser', sub { $self->on_whoisuser(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.endofwhois', sub { $self->on_endofwhois(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.account', sub { $self->on_accountnotify(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.whoisaccount', sub { $self->on_whoisaccount(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.whoisuser', sub { $self->on_whoisuser(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.endofwhois', sub { $self->on_endofwhois(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.account', sub { $self->on_accountnotify(@_) }); } sub ban_exempted { - my ($self, $channel, $hostmask) = @_; - $channel = lc $channel; - $hostmask = lc $hostmask; - return 1 if $self->{'ban-exemptions'}->exists($channel, $hostmask); - return 0; + my ($self, $channel, $hostmask) = @_; + $channel = lc $channel; + $hostmask = lc $hostmask; + return 1 if $self->{'ban-exemptions'}->exists($channel, $hostmask); + return 0; } sub ban_exempt { - my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; - my $arglist = $stuff->{arglist}; - $self->{pbot}->{interpreter}->lc_args($arglist); + my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; + my $arglist = $stuff->{arglist}; + $self->{pbot}->{interpreter}->lc_args($arglist); - my $command = $self->{pbot}->{interpreter}->shift_arg($arglist); - return "Usage: ban-exempt , where commands are: list, add, remove" if not defined $command; + my $command = $self->{pbot}->{interpreter}->shift_arg($arglist); + return "Usage: ban-exempt , where commands are: list, add, remove" if not defined $command; - given ($command) { - when ($_ eq 'list') { - my $text = "Ban-evasion exemptions:\n"; - my $entries = 0; - foreach my $channel ($self->{'ban-exemptions'}->get_keys) { - $text .= ' ' . $self->{'ban-exemptions'}->get_data($channel, '_name') . ":\n"; - foreach my $mask ($self->{'ban-exemptions'}->get_keys($channel)) { - $text .= " $mask,\n"; - $entries++; + given ($command) { + when ($_ eq 'list') { + my $text = "Ban-evasion exemptions:\n"; + my $entries = 0; + foreach my $channel ($self->{'ban-exemptions'}->get_keys) { + $text .= ' ' . $self->{'ban-exemptions'}->get_data($channel, '_name') . ":\n"; + foreach my $mask ($self->{'ban-exemptions'}->get_keys($channel)) { + $text .= " $mask,\n"; + $entries++; + } + } + $text .= "none" if $entries == 0; + return $text; } - } - $text .= "none" if $entries == 0; - return $text; - } - when ("add") { - my ($channel, $mask) = $self->{pbot}->{interpreter}->split_args($arglist, 2); - return "Usage: ban-exempt add " if not defined $channel or not defined $mask; + when ("add") { + my ($channel, $mask) = $self->{pbot}->{interpreter}->split_args($arglist, 2); + return "Usage: ban-exempt add " if not defined $channel or not defined $mask; - my $data = { - owner => "$nick!$user\@$host", - created_on => scalar gettimeofday - }; + my $data = { + owner => "$nick!$user\@$host", + created_on => scalar gettimeofday + }; - $self->{'ban-exemptions'}->add($channel, $mask, $data); - return "/say $mask exempted from ban-evasions in channel $channel"; + $self->{'ban-exemptions'}->add($channel, $mask, $data); + return "/say $mask exempted from ban-evasions in channel $channel"; + } + when ("remove") { + my ($channel, $mask) = $self->{pbot}->{interpreter}->split_args($arglist, 2); + return "Usage: ban-exempt remove " if not defined $channel or not defined $mask; + return $self->{'ban-exemptions'}->remove($channel, $mask); + } + default { return "Unknown command '$command'; commands are: list, add, remove"; } } - when ("remove") { - my ($channel, $mask) = $self->{pbot}->{interpreter}->split_args($arglist, 2); - return "Usage: ban-exempt remove " if not defined $channel or not defined $mask; - return $self->{'ban-exemptions'}->remove($channel, $mask); - } - default { - return "Unknown command '$command'; commands are: list, add, remove"; - } - } } sub update_join_watch { - my ($self, $account, $channel, $text, $mode) = @_; + my ($self, $account, $channel, $text, $mode) = @_; - return if $channel =~ /[@!]/; # ignore QUIT messages from nick!user@host channels + return if $channel =~ /[@!]/; # ignore QUIT messages from nick!user@host channels - my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $channel, 'join_watch'); + my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $channel, 'join_watch'); - if ($mode == $self->{pbot}->{messagehistory}->{MSG_JOIN}) { - $channel_data->{join_watch}++; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $channel, $channel_data); - } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}) { - # PART or QUIT - # check QUIT message for netsplits, and decrement joinwatch to allow a free rejoin - if ($text =~ /^QUIT .*\.net .*\.split/) { - if ($channel_data->{join_watch} > 0) { - $channel_data->{join_watch}--; + if ($mode == $self->{pbot}->{messagehistory}->{MSG_JOIN}) { + $channel_data->{join_watch}++; $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $channel, $channel_data); - } + } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}) { + + # PART or QUIT + # check QUIT message for netsplits, and decrement joinwatch to allow a free rejoin + if ($text =~ /^QUIT .*\.net .*\.split/) { + if ($channel_data->{join_watch} > 0) { + $channel_data->{join_watch}--; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $channel, $channel_data); + } + } + + # check QUIT message for Ping timeout or Excess Flood + elsif ($text =~ /^QUIT Excess Flood/ or $text =~ /^QUIT Max SendQ exceeded/ or $text =~ /^QUIT Ping timeout/) { + + # treat these as an extra join so they're snagged more quickly since these usually will keep flooding + $channel_data->{join_watch}++; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $channel, $channel_data); + } else { + + # some other type of QUIT or PART + } + } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_CHAT}) { + + # reset joinwatch if they send a message + if ($channel_data->{join_watch} > 0) { + $channel_data->{join_watch} = 0; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $channel, $channel_data); + } } - # check QUIT message for Ping timeout or Excess Flood - elsif ($text =~ /^QUIT Excess Flood/ or $text =~ /^QUIT Max SendQ exceeded/ or $text =~ /^QUIT Ping timeout/) { - # treat these as an extra join so they're snagged more quickly since these usually will keep flooding - $channel_data->{join_watch}++; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $channel, $channel_data); - } else { - # some other type of QUIT or PART - } - } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_CHAT}) { - # reset joinwatch if they send a message - if ($channel_data->{join_watch} > 0) { - $channel_data->{join_watch} = 0; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $channel, $channel_data); - } - } } sub check_flood { - my ($self, $channel, $nick, $user, $host, $text, $max_messages, $max_time, $mode, $stuff) = @_; - $channel = lc $channel; + my ($self, $channel, $nick, $user, $host, $text, $max_messages, $max_time, $mode, $stuff) = @_; + $channel = lc $channel; - my $mask = "$nick!$user\@$host"; - my $oldnick = $nick; - my $account; + my $mask = "$nick!$user\@$host"; + my $oldnick = $nick; + my $account; - if ($mode == $self->{pbot}->{messagehistory}->{MSG_JOIN} and exists $self->{changinghost}->{$nick}) { - $self->{pbot}->{logger}->log("Finalizing changinghost for $nick!\n"); - $account = delete $self->{changinghost}->{$nick}; + if ($mode == $self->{pbot}->{messagehistory}->{MSG_JOIN} and exists $self->{changinghost}->{$nick}) { + $self->{pbot}->{logger}->log("Finalizing changinghost for $nick!\n"); + $account = delete $self->{changinghost}->{$nick}; - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_id($mask); - if (defined $id) { - if ($id != $account) { - $self->{pbot}->{logger}->log("Linking $mask [$id] to account $account\n"); - $self->{pbot}->{messagehistory}->{database}->link_alias($account, $id, $self->{pbot}->{messagehistory}->{database}->{alias_type}->{STRONG}, 1); - } else { - $self->{pbot}->{logger}->log("New hostmask already belongs to original account.\n"); - } - $account = $id; - } else { - $self->{pbot}->{logger}->log("Adding $mask to account $account\n"); - $self->{pbot}->{messagehistory}->{database}->add_message_account($mask, $account, $self->{pbot}->{messagehistory}->{database}->{alias_type}->{STRONG}); - } - - $self->{pbot}->{messagehistory}->{database}->devalidate_all_channels($account); - my @nickserv_accounts = $self->{pbot}->{messagehistory}->{database}->get_nickserv_accounts($account); - foreach my $nickserv_account (@nickserv_accounts) { - $self->{pbot}->{logger}->log("$nick!$user\@$host [$account] seen with nickserv account [$nickserv_account]\n"); - $self->check_nickserv_accounts($nick, $nickserv_account, "$nick!$user\@$host"); - } - } else { - $account = $self->{pbot}->{messagehistory}->get_message_account($nick, $user, $host); - } - - $self->{pbot}->{messagehistory}->{database}->update_hostmask_data($mask, { last_seen => scalar gettimeofday }); - - if ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { - $self->{pbot}->{logger}->log(sprintf("%-18s | %-65s | %s\n", "NICKCHANGE", $mask, $text)); - - my ($newnick) = $text =~ m/NICKCHANGE (.*)/; - $mask = "$newnick!$user\@$host"; - $account = $self->{pbot}->{messagehistory}->get_message_account($newnick, $user, $host); - $nick = $newnick; - } else { - $self->{pbot}->{logger}->log(sprintf("%-18s | %-65s | %s\n", lc $channel eq lc $mask ? "QUIT" : $channel, $mask, $text)); - } - - # do not do flood processing for bot messages - if ($nick eq $self->{pbot}->{registry}->get_value('irc', 'botnick')) { - $self->{channels}->{$channel}->{last_spoken_nick} = $nick; - return; - } - - # don't do flood processing for unidentified or banned users in +z channels - if (defined $stuff and $stuff->{'chan-z'} and ($stuff->{'unidentified'} or $stuff->{'banned'})) { - return; - } - - my $ancestor = $self->{pbot}->{messagehistory}->{database}->get_ancestor_id($account); - $self->{pbot}->{logger}->log("Processing anti-flood account $account " . ($ancestor != $account ? "[ancestor $ancestor] " : '') . "for mask $mask\n") if $self->{pbot}->{registry}->get_value('antiflood', 'debug_account'); - - if ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { - $self->{nickflood}->{$ancestor}->{changes}++; - $self->{pbot}->{logger}->log("account $ancestor has $self->{nickflood}->{$ancestor}->{changes} nickchanges\n"); - } - - # handle QUIT events - # (these events come from $channel nick!user@host, not a specific channel or nick, - # so they need to be dispatched to all channels the nick has been seen on) - if ($mode == $self->{pbot}->{messagehistory}->{MSG_DEPARTURE} and $text =~ /^QUIT/) { - my $channels = $self->{pbot}->{nicklist}->get_channels($nick); - foreach my $chan (@$channels) { - next if $chan !~ m/^#/; - $self->update_join_watch($account, $chan, $text, $mode); - } - - $self->{pbot}->{messagehistory}->{database}->devalidate_all_channels($account); - - if ($text eq 'QUIT Changing host') { - $self->{pbot}->{logger}->log("$mask [$account] changing host!\n"); - $self->{changinghost}->{$nick} = $account; - } - - # don't do flood processing for QUIT events - return; - } - - my $channels; - if ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { - $channels = $self->{pbot}->{nicklist}->get_channels($oldnick); - } else { - $self->update_join_watch($account, $channel, $text, $mode); - push @$channels, $channel; - } - - foreach my $chan (@$channels) { - $chan = lc $chan; - # do not do flood processing if channel is not in bot's channel list or bot is not set as chanop for the channel - next if $chan =~ /^#/ and not $self->{pbot}->{chanops}->can_gain_ops($chan); - my $u = $self->{pbot}->{users}->loggedin($chan, "$nick!$user\@$host"); - - if ($chan =~ /^#/ and $mode == $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}) { - # remove validation on PART or KICK so we check for ban-evasion when user returns at a later time - my $chan_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $chan, 'validated'); - if ($chan_data->{validated} & $self->{NICKSERV_VALIDATED}) { - $chan_data->{validated} &= ~$self->{NICKSERV_VALIDATED}; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); - } - next; - } - - if ($self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted')) { - next; - } - - if ($max_messages > $self->{pbot}->{registry}->get_value('messagehistory', 'max_messages')) { - $self->{pbot}->{logger}->log("Warning: max_messages greater than max_messages limit; truncating.\n"); - $max_messages = $self->{pbot}->{registry}->get_value('messagehistory', 'max_messages'); - } - - # check for ban evasion if channel begins with # (not private message) and hasn't yet been validated against ban evasion - if ($chan =~ m/^#/) { - my $validated = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $chan, 'validated')->{'validated'}; - - if ($validated & $self->{NEEDS_CHECKBAN} or not $validated & $self->{NICKSERV_VALIDATED}) { - if ($mode == $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}) { - # don't check for evasion on PART/KICK - } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { - if (not exists $self->{whois_pending}->{$nick}) { - $self->{pbot}->{messagehistory}->{database}->set_current_nickserv_account($account, ''); - $self->{pbot}->{conn}->whois($nick); - $self->{whois_pending}->{$nick} = gettimeofday; - } - } else { - if ($mode == $self->{pbot}->{messagehistory}->{MSG_JOIN} && exists $self->{pbot}->{irc_capabilities}->{'extended-join'}) { - # don't WHOIS joins if extended-join capability is active - } elsif (not exists $self->{pbot}->{irc_capabilities}->{'account-notify'}) { - if (not exists $self->{whois_pending}->{$nick}) { - $self->{pbot}->{messagehistory}->{database}->set_current_nickserv_account($account, ''); - $self->{pbot}->{conn}->whois($nick); - $self->{whois_pending}->{$nick} = gettimeofday; - } - } else { - $self->check_bans($account, "$nick!$user\@$host", $chan); - } - } - } - } - - # do not do flood enforcement for this event if bot is lagging - if ($self->{pbot}->{lagchecker}->lagging) { - $self->{pbot}->{logger}->log("Disregarding enforcement of anti-flood due to lag: " . $self->{pbot}->{lagchecker}->lagstring . "\n"); - $self->{channels}->{$chan}->{last_spoken_nick} = $nick; - return; - } - - # do not do flood enforcement for whitelisted users - if ($self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted')) { - $self->{channels}->{$chan}->{last_spoken_nick} = $nick; - next; - } - - # do not do flood enforcement for channels that do not want it - if ($self->{pbot}->{registry}->get_value($chan, 'dont_enforce_antiflood')) { - $self->{channels}->{$chan}->{last_spoken_nick} = $nick; - next; - } - - # check for chat/join/private message flooding - if ($max_messages > 0 and $self->{pbot}->{messagehistory}->{database}->get_max_messages($account, $chan, $mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE} ? $nick : undef) >= $max_messages) { - my $msg; - if ($mode == $self->{pbot}->{messagehistory}->{MSG_CHAT}) { - $msg = $self->{pbot}->{messagehistory}->{database}->recall_message_by_count($account, $chan, $max_messages - 1) - } - elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_JOIN}) { - my $joins = $self->{pbot}->{messagehistory}->{database}->get_recent_messages($account, $chan, $max_messages, $self->{pbot}->{messagehistory}->{MSG_JOIN}); - $msg = $joins->[0]; - } - elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { - my $nickchanges = $self->{pbot}->{messagehistory}->{database}->get_recent_messages($ancestor, $chan, $max_messages, $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}, $nick); - $msg = $nickchanges->[0]; - } - elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}) { - # no flood checks to be done for departure events - next; - } - else { - $self->{pbot}->{logger}->log("Unknown flood mode [$mode] ... aborting flood enforcement.\n"); - return; - } - - my $last; - if ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { - $last = $self->{pbot}->{messagehistory}->{database}->recall_message_by_count($ancestor, $chan, 0, undef, $nick); - } else { - $last = $self->{pbot}->{messagehistory}->{database}->recall_message_by_count($account, $chan, 0); - } - - if ($last->{timestamp} - $msg->{timestamp} <= $max_time) { - if ($mode == $self->{pbot}->{messagehistory}->{MSG_JOIN}) { - my $chan_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $chan, 'offenses', 'last_offense', 'join_watch'); - #$self->{pbot}->{logger}->log("$account offenses $chan_data->{offenses}, join watch $chan_data->{join_watch}, max messages $max_messages\n"); - if ($chan_data->{join_watch} >= $max_messages) { - $chan_data->{offenses}++; - $chan_data->{last_offense} = gettimeofday; - - if ($self->{pbot}->{registry}->get_value('antiflood', 'enforce')) { - my $timeout = $self->{pbot}->{registry}->get_array_value('antiflood', 'join_flood_punishment', $chan_data->{offenses} - 1); - my $duration = duration($timeout); - my $banmask = $self->address_to_mask($host); - - if ($self->{pbot}->{channels}->is_active_op("${channel}-floodbans")) { - $self->{pbot}->{chanops}->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'join flooding', "*!$user\@$banmask\$##stop_join_flood", $chan . '-floodbans', $timeout); - $self->{pbot}->{logger}->log("$nick!$user\@$banmask banned for $duration due to join flooding (offense #" . $chan_data->{offenses} . ").\n"); - $self->{pbot}->{conn}->privmsg($nick, "You have been banned from $chan due to join flooding. If your connection issues have been fixed, or this was an accident, you may request an unban at any time by responding to this message with `unbanme`, otherwise you will be automatically unbanned in $duration."); - } else { - $self->{pbot}->{logger}->log("[anti-flood] I am not an op for ${channel}-floodbans, disregarding join-flood.\n"); - } - } - $chan_data->{join_watch} = $max_messages - 2; # give them a chance to rejoin - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); - } - } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_CHAT}) { - if ($chan =~ /^#/) { #channel flood (opposed to private message or otherwise) - # don't increment offenses again if already banned - if ($self->{pbot}->{chanops}->has_ban_timeout($chan, "*!$user\@" . $self->address_to_mask($host))) { - $self->{pbot}->{logger}->log("$nick $chan flood offense disregarded due to existing ban\n"); - next; - } - - my $chan_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $chan, 'offenses', 'last_offense'); - $chan_data->{offenses}++; - $chan_data->{last_offense} = gettimeofday; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); - - if ($self->{pbot}->{registry}->get_value('antiflood', 'enforce')) { - my $length = $self->{pbot}->{registry}->get_array_value('antiflood', 'chat_flood_punishment', $chan_data->{offenses} - 1); - - $self->{pbot}->{chanops}->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'chat flooding', "*!$user\@" . $self->address_to_mask($host), $chan, $length); - $length = duration($length); - $self->{pbot}->{logger}->log("$nick $chan flood offense " . $chan_data->{offenses} . " earned $length ban\n"); - $self->{pbot}->{conn}->privmsg($nick, "You have been muted due to flooding. Please use a web paste service such as http://codepad.org for lengthy pastes. You will be allowed to speak again in approximately $length."); - } - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); - } - else { # private message flood - my $hostmask = $self->address_to_mask($host); - $hostmask =~ s/\*/.*/g; - next if exists $self->{pbot}->{ignorelist}->{ignore_list}->{".*!$user\@$hostmask"}->{$chan}; - - my $chan_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $chan, 'offenses', 'last_offense'); - $chan_data->{offenses}++; - $chan_data->{last_offense} = gettimeofday; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); - - my $length = $self->{pbot}->{registry}->get_array_value('antiflood', 'chat_flood_punishment', $chan_data->{offenses} - 1); - - $self->{pbot}->{ignorelist}->add(".*!$user\@$hostmask", $chan, $length); - $length = duration($length); - $self->{pbot}->{logger}->log("$nick msg flood offense " . $chan_data->{offenses} . " earned $length ignore\n"); - $self->{pbot}->{conn}->privmsg($nick, "You have used too many commands in too short a time period, you have been ignored for $length."); - } - next; - } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE} and $self->{nickflood}->{$ancestor}->{changes} >= $max_messages) { - next if $chan !~ /^#/; - ($nick) = $text =~ m/NICKCHANGE (.*)/; - - $self->{nickflood}->{$ancestor}->{offenses}++; - $self->{nickflood}->{$ancestor}->{changes} = $max_messages - 2; # allow 1 more change (to go back to original nick) - $self->{nickflood}->{$ancestor}->{timestamp} = gettimeofday; - - if ($self->{pbot}->{registry}->get_value('antiflood', 'enforce')) { - my $length = $self->{pbot}->{registry}->get_array_value('antiflood', 'nick_flood_punishment', $self->{nickflood}->{$ancestor}->{offenses} - 1); - $self->{pbot}->{chanops}->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'nick flooding', "*!$user\@" . $self->address_to_mask($host), $chan, $length); - $length = duration($length); - $self->{pbot}->{logger}->log("$nick nickchange flood offense " . $self->{nickflood}->{$ancestor}->{offenses} . " earned $length ban\n"); - $self->{pbot}->{conn}->privmsg($nick, "You have been temporarily banned due to nick-change flooding. You will be unbanned in $length."); - } - } - } - } - - # check for enter abuse - if ($mode == $self->{pbot}->{messagehistory}->{MSG_CHAT} and $chan =~ m/^#/) { - my $chan_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $chan, 'enter_abuse', 'enter_abuses', 'offenses'); - my $other_offenses = delete $chan_data->{offenses}; - my $debug_enter_abuse = $self->{pbot}->{registry}->get_value('antiflood', 'debug_enter_abuse'); - - if (defined $self->{channels}->{$chan}->{last_spoken_nick} and $nick eq $self->{channels}->{$chan}->{last_spoken_nick}) { - my $messages = $self->{pbot}->{messagehistory}->{database}->get_recent_messages($account, $chan, 2, $self->{pbot}->{messagehistory}->{MSG_CHAT}); - - my $enter_abuse_threshold = $self->{pbot}->{registry}->get_value($chan, 'enter_abuse_threshold'); - my $enter_abuse_time_threshold = $self->{pbot}->{registry}->get_value($chan, 'enter_abuse_time_threshold'); - my $enter_abuse_max_offenses = $self->{pbot}->{registry}->get_value($chan, 'enter_abuse_max_offenses'); - - $enter_abuse_threshold = $self->{pbot}->{registry}->get_value('antiflood', 'enter_abuse_threshold') if not defined $enter_abuse_threshold; - $enter_abuse_time_threshold = $self->{pbot}->{registry}->get_value('antiflood', 'enter_abuse_time_threshold') if not defined $enter_abuse_time_threshold; - $enter_abuse_max_offenses = $self->{pbot}->{registry}->get_value('antiflood', 'enter_abuse_max_offenses') if not defined $enter_abuse_max_offenses; - - if ($messages->[1]->{timestamp} - $messages->[0]->{timestamp} <= $enter_abuse_time_threshold) { - if (++$chan_data->{enter_abuse} >= $enter_abuse_threshold - 1) { - $chan_data->{enter_abuse} = $enter_abuse_threshold / 2 - 1; - $chan_data->{enter_abuses}++; - if ($chan_data->{enter_abuses} >= $enter_abuse_max_offenses) { - if ($self->{pbot}->{registry}->get_value('antiflood', 'enforce')) { - if ($self->{pbot}->{chanops}->has_ban_timeout($chan, "*!$user\@" . $self->address_to_mask($host))) { - $self->{pbot}->{logger}->log("$nick $chan enter abuse offense disregarded due to existing ban\n"); - next; - } - - my $offenses = $chan_data->{enter_abuses} - $enter_abuse_max_offenses + 1 + $other_offenses; - my $ban_length = $self->{pbot}->{registry}->get_array_value('antiflood', 'enter_abuse_punishment', $offenses - 1); - $self->{pbot}->{chanops}->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'enter abuse', "*!$user\@" . $self->address_to_mask($host), $chan, $ban_length); - $ban_length = duration($ban_length); - $self->{pbot}->{logger}->log("$nick $chan enter abuse offense " . $chan_data->{enter_abuses} . " earned $ban_length ban\n"); - $self->{pbot}->{conn}->privmsg($nick, "You have been muted due to abusing the enter key. Please do not split your sentences over multiple messages. You will be allowed to speak again in approximately $ban_length."); - $chan_data->{last_offense} = gettimeofday; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); - next; - } + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_id($mask); + if (defined $id) { + if ($id != $account) { + $self->{pbot}->{logger}->log("Linking $mask [$id] to account $account\n"); + $self->{pbot}->{messagehistory}->{database}->link_alias($account, $id, $self->{pbot}->{messagehistory}->{database}->{alias_type}->{STRONG}, 1); } else { - $self->{pbot}->{logger}->log("$nick $chan enter abuses counter incremented to " . $chan_data->{enter_abuses} . "\n") if $debug_enter_abuse; - if ($chan_data->{enter_abuses} == $enter_abuse_max_offenses - 1 && $chan_data->{enter_abuse} == $enter_abuse_threshold / 2 - 1) { - if ($self->{pbot}->{registry}->get_value('antiflood', 'enforce')) { - $self->{pbot}->{conn}->privmsg($chan, "$nick: Please stop abusing the enter key. Feel free to type longer messages and to take a moment to think of anything else to say before you hit that enter key."); - } - } + $self->{pbot}->{logger}->log("New hostmask already belongs to original account.\n"); } - } else { - $self->{pbot}->{logger}->log("$nick $chan enter abuse counter incremented to " . $chan_data->{enter_abuse} . "\n") if $debug_enter_abuse; - } - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); + $account = $id; } else { - if ($chan_data->{enter_abuse} > 0) { - $self->{pbot}->{logger}->log("$nick $chan more than $enter_abuse_time_threshold seconds since last message, enter abuse counter reset\n") if $debug_enter_abuse; - $chan_data->{enter_abuse} = 0; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); - } + $self->{pbot}->{logger}->log("Adding $mask to account $account\n"); + $self->{pbot}->{messagehistory}->{database}->add_message_account($mask, $account, $self->{pbot}->{messagehistory}->{database}->{alias_type}->{STRONG}); } - } else { - $self->{channels}->{$chan}->{last_spoken_nick} = $nick; - $self->{pbot}->{logger}->log("last spoken nick set to $nick\n") if $debug_enter_abuse; - if ($chan_data->{enter_abuse} > 0) { - $self->{pbot}->{logger}->log("$nick $chan enter abuse counter reset\n") if $debug_enter_abuse; - $chan_data->{enter_abuse} = 0; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); + + $self->{pbot}->{messagehistory}->{database}->devalidate_all_channels($account); + my @nickserv_accounts = $self->{pbot}->{messagehistory}->{database}->get_nickserv_accounts($account); + foreach my $nickserv_account (@nickserv_accounts) { + $self->{pbot}->{logger}->log("$nick!$user\@$host [$account] seen with nickserv account [$nickserv_account]\n"); + $self->check_nickserv_accounts($nick, $nickserv_account, "$nick!$user\@$host"); + } + } else { + $account = $self->{pbot}->{messagehistory}->get_message_account($nick, $user, $host); + } + + $self->{pbot}->{messagehistory}->{database}->update_hostmask_data($mask, {last_seen => scalar gettimeofday}); + + if ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { + $self->{pbot}->{logger}->log(sprintf("%-18s | %-65s | %s\n", "NICKCHANGE", $mask, $text)); + + my ($newnick) = $text =~ m/NICKCHANGE (.*)/; + $mask = "$newnick!$user\@$host"; + $account = $self->{pbot}->{messagehistory}->get_message_account($newnick, $user, $host); + $nick = $newnick; + } else { + $self->{pbot}->{logger}->log(sprintf("%-18s | %-65s | %s\n", lc $channel eq lc $mask ? "QUIT" : $channel, $mask, $text)); + } + + # do not do flood processing for bot messages + if ($nick eq $self->{pbot}->{registry}->get_value('irc', 'botnick')) { + $self->{channels}->{$channel}->{last_spoken_nick} = $nick; + return; + } + + # don't do flood processing for unidentified or banned users in +z channels + if (defined $stuff and $stuff->{'chan-z'} and ($stuff->{'unidentified'} or $stuff->{'banned'})) { return; } + + my $ancestor = $self->{pbot}->{messagehistory}->{database}->get_ancestor_id($account); + $self->{pbot}->{logger}->log("Processing anti-flood account $account " . ($ancestor != $account ? "[ancestor $ancestor] " : '') . "for mask $mask\n") + if $self->{pbot}->{registry}->get_value('antiflood', 'debug_account'); + + if ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { + $self->{nickflood}->{$ancestor}->{changes}++; + $self->{pbot}->{logger}->log("account $ancestor has $self->{nickflood}->{$ancestor}->{changes} nickchanges\n"); + } + + # handle QUIT events + # (these events come from $channel nick!user@host, not a specific channel or nick, + # so they need to be dispatched to all channels the nick has been seen on) + if ($mode == $self->{pbot}->{messagehistory}->{MSG_DEPARTURE} and $text =~ /^QUIT/) { + my $channels = $self->{pbot}->{nicklist}->get_channels($nick); + foreach my $chan (@$channels) { + next if $chan !~ m/^#/; + $self->update_join_watch($account, $chan, $text, $mode); + } + + $self->{pbot}->{messagehistory}->{database}->devalidate_all_channels($account); + + if ($text eq 'QUIT Changing host') { + $self->{pbot}->{logger}->log("$mask [$account] changing host!\n"); + $self->{changinghost}->{$nick} = $account; + } + + # don't do flood processing for QUIT events + return; + } + + my $channels; + if ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { $channels = $self->{pbot}->{nicklist}->get_channels($oldnick); } + else { + $self->update_join_watch($account, $channel, $text, $mode); + push @$channels, $channel; + } + + foreach my $chan (@$channels) { + $chan = lc $chan; + + # do not do flood processing if channel is not in bot's channel list or bot is not set as chanop for the channel + next if $chan =~ /^#/ and not $self->{pbot}->{chanops}->can_gain_ops($chan); + my $u = $self->{pbot}->{users}->loggedin($chan, "$nick!$user\@$host"); + + if ($chan =~ /^#/ and $mode == $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}) { + + # remove validation on PART or KICK so we check for ban-evasion when user returns at a later time + my $chan_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $chan, 'validated'); + if ($chan_data->{validated} & $self->{NICKSERV_VALIDATED}) { + $chan_data->{validated} &= ~$self->{NICKSERV_VALIDATED}; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); + } + next; + } + + if ($self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted')) { next; } + + if ($max_messages > $self->{pbot}->{registry}->get_value('messagehistory', 'max_messages')) { + $self->{pbot}->{logger}->log("Warning: max_messages greater than max_messages limit; truncating.\n"); + $max_messages = $self->{pbot}->{registry}->get_value('messagehistory', 'max_messages'); + } + + # check for ban evasion if channel begins with # (not private message) and hasn't yet been validated against ban evasion + if ($chan =~ m/^#/) { + my $validated = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $chan, 'validated')->{'validated'}; + + if ($validated & $self->{NEEDS_CHECKBAN} or not $validated & $self->{NICKSERV_VALIDATED}) { + if ($mode == $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}) { + + # don't check for evasion on PART/KICK + } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { + if (not exists $self->{whois_pending}->{$nick}) { + $self->{pbot}->{messagehistory}->{database}->set_current_nickserv_account($account, ''); + $self->{pbot}->{conn}->whois($nick); + $self->{whois_pending}->{$nick} = gettimeofday; + } + } else { + if ($mode == $self->{pbot}->{messagehistory}->{MSG_JOIN} && exists $self->{pbot}->{irc_capabilities}->{'extended-join'}) { + + # don't WHOIS joins if extended-join capability is active + } elsif (not exists $self->{pbot}->{irc_capabilities}->{'account-notify'}) { + if (not exists $self->{whois_pending}->{$nick}) { + $self->{pbot}->{messagehistory}->{database}->set_current_nickserv_account($account, ''); + $self->{pbot}->{conn}->whois($nick); + $self->{whois_pending}->{$nick} = gettimeofday; + } + } else { + $self->check_bans($account, "$nick!$user\@$host", $chan); + } + } + } + } + + # do not do flood enforcement for this event if bot is lagging + if ($self->{pbot}->{lagchecker}->lagging) { + $self->{pbot}->{logger}->log("Disregarding enforcement of anti-flood due to lag: " . $self->{pbot}->{lagchecker}->lagstring . "\n"); + $self->{channels}->{$chan}->{last_spoken_nick} = $nick; + return; + } + + # do not do flood enforcement for whitelisted users + if ($self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted')) { + $self->{channels}->{$chan}->{last_spoken_nick} = $nick; + next; + } + + # do not do flood enforcement for channels that do not want it + if ($self->{pbot}->{registry}->get_value($chan, 'dont_enforce_antiflood')) { + $self->{channels}->{$chan}->{last_spoken_nick} = $nick; + next; + } + + # check for chat/join/private message flooding + if ( $max_messages > 0 + and $self->{pbot}->{messagehistory}->{database}->get_max_messages($account, $chan, $mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE} ? $nick : undef) >= + $max_messages) + { + my $msg; + if ($mode == $self->{pbot}->{messagehistory}->{MSG_CHAT}) { + $msg = $self->{pbot}->{messagehistory}->{database}->recall_message_by_count($account, $chan, $max_messages - 1); + } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_JOIN}) { + my $joins = $self->{pbot}->{messagehistory}->{database}->get_recent_messages($account, $chan, $max_messages, $self->{pbot}->{messagehistory}->{MSG_JOIN}); + $msg = $joins->[0]; + } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { + my $nickchanges = + $self->{pbot}->{messagehistory}->{database}->get_recent_messages($ancestor, $chan, $max_messages, $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}, $nick); + $msg = $nickchanges->[0]; + } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}) { + + # no flood checks to be done for departure events + next; + } else { + $self->{pbot}->{logger}->log("Unknown flood mode [$mode] ... aborting flood enforcement.\n"); + return; + } + + my $last; + if ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { + $last = $self->{pbot}->{messagehistory}->{database}->recall_message_by_count($ancestor, $chan, 0, undef, $nick); + } else { + $last = $self->{pbot}->{messagehistory}->{database}->recall_message_by_count($account, $chan, 0); + } + + if ($last->{timestamp} - $msg->{timestamp} <= $max_time) { + if ($mode == $self->{pbot}->{messagehistory}->{MSG_JOIN}) { + my $chan_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $chan, 'offenses', 'last_offense', 'join_watch'); + + #$self->{pbot}->{logger}->log("$account offenses $chan_data->{offenses}, join watch $chan_data->{join_watch}, max messages $max_messages\n"); + if ($chan_data->{join_watch} >= $max_messages) { + $chan_data->{offenses}++; + $chan_data->{last_offense} = gettimeofday; + + if ($self->{pbot}->{registry}->get_value('antiflood', 'enforce')) { + my $timeout = $self->{pbot}->{registry}->get_array_value('antiflood', 'join_flood_punishment', $chan_data->{offenses} - 1); + my $duration = duration($timeout); + my $banmask = $self->address_to_mask($host); + + if ($self->{pbot}->{channels}->is_active_op("${channel}-floodbans")) { + $self->{pbot}->{chanops} + ->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'join flooding', "*!$user\@$banmask\$##stop_join_flood", $chan . '-floodbans', $timeout); + $self->{pbot}->{logger}->log("$nick!$user\@$banmask banned for $duration due to join flooding (offense #" . $chan_data->{offenses} . ").\n"); + $self->{pbot}->{conn}->privmsg( + $nick, + "You have been banned from $chan due to join flooding. If your connection issues have been fixed, or this was an accident, you may request an unban at any time by responding to this message with `unbanme`, otherwise you will be automatically unbanned in $duration." + ); + } else { + $self->{pbot}->{logger}->log("[anti-flood] I am not an op for ${channel}-floodbans, disregarding join-flood.\n"); + } + } + $chan_data->{join_watch} = $max_messages - 2; # give them a chance to rejoin + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); + } + } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_CHAT}) { + if ($chan =~ /^#/) { #channel flood (opposed to private message or otherwise) + # don't increment offenses again if already banned + if ($self->{pbot}->{chanops}->has_ban_timeout($chan, "*!$user\@" . $self->address_to_mask($host))) { + $self->{pbot}->{logger}->log("$nick $chan flood offense disregarded due to existing ban\n"); + next; + } + + my $chan_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $chan, 'offenses', 'last_offense'); + $chan_data->{offenses}++; + $chan_data->{last_offense} = gettimeofday; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); + + if ($self->{pbot}->{registry}->get_value('antiflood', 'enforce')) { + my $length = $self->{pbot}->{registry}->get_array_value('antiflood', 'chat_flood_punishment', $chan_data->{offenses} - 1); + + $self->{pbot}->{chanops} + ->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'chat flooding', "*!$user\@" . $self->address_to_mask($host), $chan, $length); + $length = duration($length); + $self->{pbot}->{logger}->log("$nick $chan flood offense " . $chan_data->{offenses} . " earned $length ban\n"); + $self->{pbot}->{conn}->privmsg( + $nick, + "You have been muted due to flooding. Please use a web paste service such as http://codepad.org for lengthy pastes. You will be allowed to speak again in approximately $length." + ); + } + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); + } else { # private message flood + my $hostmask = $self->address_to_mask($host); + $hostmask =~ s/\*/.*/g; + next if exists $self->{pbot}->{ignorelist}->{ignore_list}->{".*!$user\@$hostmask"}->{$chan}; + + my $chan_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $chan, 'offenses', 'last_offense'); + $chan_data->{offenses}++; + $chan_data->{last_offense} = gettimeofday; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); + + my $length = $self->{pbot}->{registry}->get_array_value('antiflood', 'chat_flood_punishment', $chan_data->{offenses} - 1); + + $self->{pbot}->{ignorelist}->add(".*!$user\@$hostmask", $chan, $length); + $length = duration($length); + $self->{pbot}->{logger}->log("$nick msg flood offense " . $chan_data->{offenses} . " earned $length ignore\n"); + $self->{pbot}->{conn}->privmsg($nick, "You have used too many commands in too short a time period, you have been ignored for $length."); + } + next; + } elsif ($mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE} and $self->{nickflood}->{$ancestor}->{changes} >= $max_messages) { + next if $chan !~ /^#/; + ($nick) = $text =~ m/NICKCHANGE (.*)/; + + $self->{nickflood}->{$ancestor}->{offenses}++; + $self->{nickflood}->{$ancestor}->{changes} = $max_messages - 2; # allow 1 more change (to go back to original nick) + $self->{nickflood}->{$ancestor}->{timestamp} = gettimeofday; + + if ($self->{pbot}->{registry}->get_value('antiflood', 'enforce')) { + my $length = $self->{pbot}->{registry}->get_array_value('antiflood', 'nick_flood_punishment', $self->{nickflood}->{$ancestor}->{offenses} - 1); + $self->{pbot}->{chanops} + ->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'nick flooding', "*!$user\@" . $self->address_to_mask($host), $chan, $length); + $length = duration($length); + $self->{pbot}->{logger}->log("$nick nickchange flood offense " . $self->{nickflood}->{$ancestor}->{offenses} . " earned $length ban\n"); + $self->{pbot}->{conn}->privmsg($nick, "You have been temporarily banned due to nick-change flooding. You will be unbanned in $length."); + } + } + } + } + + # check for enter abuse + if ($mode == $self->{pbot}->{messagehistory}->{MSG_CHAT} and $chan =~ m/^#/) { + my $chan_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $chan, 'enter_abuse', 'enter_abuses', 'offenses'); + my $other_offenses = delete $chan_data->{offenses}; + my $debug_enter_abuse = $self->{pbot}->{registry}->get_value('antiflood', 'debug_enter_abuse'); + + if (defined $self->{channels}->{$chan}->{last_spoken_nick} and $nick eq $self->{channels}->{$chan}->{last_spoken_nick}) { + my $messages = $self->{pbot}->{messagehistory}->{database}->get_recent_messages($account, $chan, 2, $self->{pbot}->{messagehistory}->{MSG_CHAT}); + + my $enter_abuse_threshold = $self->{pbot}->{registry}->get_value($chan, 'enter_abuse_threshold'); + my $enter_abuse_time_threshold = $self->{pbot}->{registry}->get_value($chan, 'enter_abuse_time_threshold'); + my $enter_abuse_max_offenses = $self->{pbot}->{registry}->get_value($chan, 'enter_abuse_max_offenses'); + + $enter_abuse_threshold = $self->{pbot}->{registry}->get_value('antiflood', 'enter_abuse_threshold') if not defined $enter_abuse_threshold; + $enter_abuse_time_threshold = $self->{pbot}->{registry}->get_value('antiflood', 'enter_abuse_time_threshold') if not defined $enter_abuse_time_threshold; + $enter_abuse_max_offenses = $self->{pbot}->{registry}->get_value('antiflood', 'enter_abuse_max_offenses') if not defined $enter_abuse_max_offenses; + + if ($messages->[1]->{timestamp} - $messages->[0]->{timestamp} <= $enter_abuse_time_threshold) { + if (++$chan_data->{enter_abuse} >= $enter_abuse_threshold - 1) { + $chan_data->{enter_abuse} = $enter_abuse_threshold / 2 - 1; + $chan_data->{enter_abuses}++; + if ($chan_data->{enter_abuses} >= $enter_abuse_max_offenses) { + if ($self->{pbot}->{registry}->get_value('antiflood', 'enforce')) { + if ($self->{pbot}->{chanops}->has_ban_timeout($chan, "*!$user\@" . $self->address_to_mask($host))) { + $self->{pbot}->{logger}->log("$nick $chan enter abuse offense disregarded due to existing ban\n"); + next; + } + + my $offenses = $chan_data->{enter_abuses} - $enter_abuse_max_offenses + 1 + $other_offenses; + my $ban_length = $self->{pbot}->{registry}->get_array_value('antiflood', 'enter_abuse_punishment', $offenses - 1); + $self->{pbot}->{chanops} + ->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'enter abuse', "*!$user\@" . $self->address_to_mask($host), $chan, $ban_length); + $ban_length = duration($ban_length); + $self->{pbot}->{logger}->log("$nick $chan enter abuse offense " . $chan_data->{enter_abuses} . " earned $ban_length ban\n"); + $self->{pbot}->{conn}->privmsg( + $nick, + "You have been muted due to abusing the enter key. Please do not split your sentences over multiple messages. You will be allowed to speak again in approximately $ban_length." + ); + $chan_data->{last_offense} = gettimeofday; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); + next; + } + } else { + $self->{pbot}->{logger}->log("$nick $chan enter abuses counter incremented to " . $chan_data->{enter_abuses} . "\n") if $debug_enter_abuse; + if ($chan_data->{enter_abuses} == $enter_abuse_max_offenses - 1 && $chan_data->{enter_abuse} == $enter_abuse_threshold / 2 - 1) { + if ($self->{pbot}->{registry}->get_value('antiflood', 'enforce')) { + $self->{pbot}->{conn}->privmsg( + $chan, + "$nick: Please stop abusing the enter key. Feel free to type longer messages and to take a moment to think of anything else to say before you hit that enter key." + ); + } + } + } + } else { + $self->{pbot}->{logger}->log("$nick $chan enter abuse counter incremented to " . $chan_data->{enter_abuse} . "\n") if $debug_enter_abuse; + } + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); + } else { + if ($chan_data->{enter_abuse} > 0) { + $self->{pbot}->{logger}->log("$nick $chan more than $enter_abuse_time_threshold seconds since last message, enter abuse counter reset\n") if $debug_enter_abuse; + $chan_data->{enter_abuse} = 0; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); + } + } + } else { + $self->{channels}->{$chan}->{last_spoken_nick} = $nick; + $self->{pbot}->{logger}->log("last spoken nick set to $nick\n") if $debug_enter_abuse; + if ($chan_data->{enter_abuse} > 0) { + $self->{pbot}->{logger}->log("$nick $chan enter abuse counter reset\n") if $debug_enter_abuse; + $chan_data->{enter_abuse} = 0; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $chan, $chan_data); + } + } } - } } - } } sub unbanme { - my ($self, $from, $nick, $user, $host, $arguments) = @_; - my $unbanned; + my ($self, $from, $nick, $user, $host, $arguments) = @_; + my $unbanned; - my %aliases = $self->{pbot}->{messagehistory}->{database}->get_also_known_as($nick); + my %aliases = $self->{pbot}->{messagehistory}->{database}->get_also_known_as($nick); - foreach my $alias (keys %aliases) { - next if $aliases{$alias}->{type} == $self->{pbot}->{messagehistory}->{database}->{alias_type}->{WEAK}; - next if $aliases{$alias}->{nickchange} == 1; + foreach my $alias (keys %aliases) { + next if $aliases{$alias}->{type} == $self->{pbot}->{messagehistory}->{database}->{alias_type}->{WEAK}; + next if $aliases{$alias}->{nickchange} == 1; - my ($anick, $auser, $ahost) = $alias =~ m/([^!]+)!([^@]+)@(.*)/; - my $banmask = $self->address_to_mask($ahost); - my $mask = "*!$auser\@$banmask\$##stop_join_flood"; + my ($anick, $auser, $ahost) = $alias =~ m/([^!]+)!([^@]+)@(.*)/; + my $banmask = $self->address_to_mask($ahost); + my $mask = "*!$auser\@$banmask\$##stop_join_flood"; - my @channels = $self->{pbot}->{messagehistory}->{database}->get_channels($aliases{$alias}->{id}); + my @channels = $self->{pbot}->{messagehistory}->{database}->get_channels($aliases{$alias}->{id}); - foreach my $channel (@channels) { - next if exists $unbanned->{$channel} and exists $unbanned->{$channel}->{$mask}; - next if not $self->{pbot}->{chanops}->{unban_timeout}->exists($channel . '-floodbans', $mask); + foreach my $channel (@channels) { + next if exists $unbanned->{$channel} and exists $unbanned->{$channel}->{$mask}; + next if not $self->{pbot}->{chanops}->{unban_timeout}->exists($channel . '-floodbans', $mask); - my $message_account = $self->{pbot}->{messagehistory}->{database}->get_message_account($anick, $auser, $ahost); - my @nickserv_accounts = $self->{pbot}->{messagehistory}->{database}->get_nickserv_accounts($message_account); + my $message_account = $self->{pbot}->{messagehistory}->{database}->get_message_account($anick, $auser, $ahost); + my @nickserv_accounts = $self->{pbot}->{messagehistory}->{database}->get_nickserv_accounts($message_account); - push @nickserv_accounts, undef; + push @nickserv_accounts, undef; - foreach my $nickserv_account (@nickserv_accounts) { - my $baninfos = $self->{pbot}->{bantracker}->get_baninfo("$anick!$auser\@$ahost", $channel, $nickserv_account); + foreach my $nickserv_account (@nickserv_accounts) { + my $baninfos = $self->{pbot}->{bantracker}->get_baninfo("$anick!$auser\@$ahost", $channel, $nickserv_account); - if (defined $baninfos) { - foreach my $baninfo (@$baninfos) { - my $u = $self->{pbot}->{users}->loggedin($baninfo->{channel}, "$nick!$user\@$host"); - my $whitelisted = $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted'); - if ($self->ban_exempted($baninfo->{channel}, $baninfo->{banmask}) || $whitelisted) { - $self->{pbot}->{logger}->log("anti-flood: [unbanme] $anick!$auser\@$ahost 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("anti-flood: [unbanme] $anick!$auser\@$ahost $mode as $baninfo->{banmask} in $baninfo->{channel} by $baninfo->{owner}, unbanme rejected\n"); - return "/msg $nick You have been $mode as $baninfo->{banmask} by $baninfo->{owner}, unbanme will not work until it is removed."; - } + if (defined $baninfos) { + foreach my $baninfo (@$baninfos) { + my $u = $self->{pbot}->{users}->loggedin($baninfo->{channel}, "$nick!$user\@$host"); + my $whitelisted = $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted'); + if ($self->ban_exempted($baninfo->{channel}, $baninfo->{banmask}) || $whitelisted) { + $self->{pbot}->{logger}->log("anti-flood: [unbanme] $anick!$auser\@$ahost 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("anti-flood: [unbanme] $anick!$auser\@$ahost $mode as $baninfo->{banmask} in $baninfo->{channel} by $baninfo->{owner}, unbanme rejected\n"); + return "/msg $nick You have been $mode as $baninfo->{banmask} by $baninfo->{owner}, unbanme will not work until it is removed."; + } + } + } + } } - } + + my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($message_account, $channel, 'unbanmes'); + if ($channel_data->{unbanmes} <= 2) { + $channel_data->{unbanmes}++; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($message_account, $channel, $channel_data); + } + + $unbanned->{$channel}->{$mask} = $channel_data->{unbanmes}; } - } - - my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($message_account, $channel, 'unbanmes'); - if ($channel_data->{unbanmes} <= 2) { - $channel_data->{unbanmes}++; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($message_account, $channel, $channel_data); - } - - $unbanned->{$channel}->{$mask} = $channel_data->{unbanmes}; } - } + if (keys %$unbanned) { - if (keys %$unbanned) { - my $channels = ''; - my $sep = ''; - my $channels_warning = ''; - my $sep_warning = ''; - my $channels_disabled = ''; - my $sep_disabled = ''; - foreach my $channel (keys %$unbanned) { - foreach my $mask (keys %{ $unbanned->{$channel} }) { - if ($self->{pbot}->{channels}->is_active_op("${channel}-floodbans")) { + my $channels = ''; - if ($unbanned->{$channel}->{$mask} <= 2) { - $self->{pbot}->{chanops}->unban_user($mask, $channel . '-floodbans'); - $channels .= "$sep$channel"; - $sep = ", "; - } + my $sep = ''; + my $channels_warning = ''; + my $sep_warning = ''; + my $channels_disabled = ''; + my $sep_disabled = ''; - if ($unbanned->{$channel}->{$mask} == 1) { - $channels_warning .= "$sep_warning$channel"; - $sep_warning = ", "; - } else { - $channels_disabled .= "$sep_disabled$channel"; - $sep_disabled = ", "; - } + foreach my $channel (keys %$unbanned) { + foreach my $mask (keys %{$unbanned->{$channel}}) { + if ($self->{pbot}->{channels}->is_active_op("${channel}-floodbans")) { + + if ($unbanned->{$channel}->{$mask} <= 2) { + $self->{pbot}->{chanops}->unban_user($mask, $channel . '-floodbans'); + $channels .= "$sep$channel"; + $sep = ", "; + } + + if ($unbanned->{$channel}->{$mask} == 1) { + $channels_warning .= "$sep_warning$channel"; + $sep_warning = ", "; + } else { + $channels_disabled .= "$sep_disabled$channel"; + $sep_disabled = ", "; + } + } + } } - } - } - $self->{pbot}->{chanops}->check_unban_queue(); + $self->{pbot}->{chanops}->check_unban_queue(); - $channels =~ s/(.*), /$1 and /; - $channels_warning =~ s/(.*), /$1 and /; - $channels_disabled =~ s/(.*), /$1 and /; + $channels =~ s/(.*), /$1 and /; + $channels_warning =~ s/(.*), /$1 and /; + $channels_disabled =~ s/(.*), /$1 and /; - my $warning = ''; + my $warning = ''; - if (length $channels_warning) { - $warning = " You may use `unbanme` one more time today for $channels_warning; please ensure that your client or connection issues are resolved before using your final `unbanme` of the day."; - } + if (length $channels_warning) { + $warning = + " You may use `unbanme` one more time today for $channels_warning; please ensure that your client or connection issues are resolved before using your final `unbanme` of the day."; + } - if (length $channels_disabled) { - $warning .= " You may not use `unbanme` again for several hours for $channels_disabled; ensure that your client or connection issues are resolved, otherwise leave the channel until they are or you will be temporarily banned for several hours if you join-flood again during this period."; - } + if (length $channels_disabled) { + $warning .= + " You may not use `unbanme` again for several hours for $channels_disabled; ensure that your client or connection issues are resolved, otherwise leave the channel until they are or you will be temporarily banned for several hours if you join-flood again during this period."; + } - if (length $channels) { - return "/msg $nick You have been unbanned from $channels.$warning"; + if (length $channels) { return "/msg $nick You have been unbanned from $channels.$warning"; } + else { return "/msg $nick You were not unbanned at this time.$warning"; } } else { - return "/msg $nick You were not unbanned at this time.$warning"; + return "/msg $nick There is no join-flooding ban set for you."; } - } else { - return "/msg $nick There is no join-flooding ban set for you."; - } } sub address_to_mask { - my ($self, $address) = @_; - my $banmask; + my ($self, $address) = @_; + my $banmask; - if ($address =~ m/^([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)$/) { - my ($a, $b, $c, $d) = ($1, $2, $3, $4); - given ($a) { - when ($_ <= 127) { $banmask = "$a.*"; } - when ($_ <= 191) { $banmask = "$a.$b.*"; } - default { $banmask = "$a.$b.$c.*"; } + if ($address =~ m/^([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)$/) { + my ($a, $b, $c, $d) = ($1, $2, $3, $4); + given ($a) { + when ($_ <= 127) { $banmask = "$a.*"; } + when ($_ <= 191) { $banmask = "$a.$b.*"; } + default { $banmask = "$a.$b.$c.*"; } + } + } elsif ($address =~ m{^gateway/([^/]+)/([^/]+)/}) { + $banmask = "gateway/$1/$2/*"; + } elsif ($address =~ m{^nat/([^/]+)/}) { + $banmask = "nat/$1/*"; + } elsif ($address =~ m/^([^:]+):([^:]*):([^:]*):([^:]*):([^:]*):([^:]*):([^:]*):([^:]*)$/) { + $banmask = "$1:$2:*"; + } elsif ($address =~ m/[^.]+\.([^.]+\.[a-zA-Z]+)$/) { + $banmask = "*.$1"; + } else { + $banmask = $address; } - } elsif ($address =~ m{^gateway/([^/]+)/([^/]+)/}) { - $banmask = "gateway/$1/$2/*"; - } elsif ($address =~ m{^nat/([^/]+)/}) { - $banmask = "nat/$1/*"; - } elsif ($address =~ m/^([^:]+):([^:]*):([^:]*):([^:]*):([^:]*):([^:]*):([^:]*):([^:]*)$/) { - $banmask = "$1:$2:*"; - } elsif ($address =~ m/[^.]+\.([^.]+\.[a-zA-Z]+)$/) { - $banmask = "*.$1"; - } else { - $banmask = $address; - } - return $banmask; + return $banmask; } sub devalidate_accounts { - # remove validation on accounts in $channel that match a ban/quiet $mask - my ($self, $mask, $channel) = @_; - my @message_accounts; - #$self->{pbot}->{logger}->log("Devalidating accounts for $mask in $channel\n"); + # remove validation on accounts in $channel that match a ban/quiet $mask + my ($self, $mask, $channel) = @_; + my @message_accounts; - if ($mask =~ m/^\$a:(.*)/) { - my $ban_account = lc $1; - @message_accounts = $self->{pbot}->{messagehistory}->{database}->find_message_accounts_by_nickserv($ban_account); - } else { - @message_accounts = $self->{pbot}->{messagehistory}->{database}->find_message_accounts_by_mask($mask); - } + #$self->{pbot}->{logger}->log("Devalidating accounts for $mask in $channel\n"); - foreach my $account (@message_accounts) { - my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $channel, 'validated'); - if (defined $channel_data and $channel_data->{validated} & $self->{NICKSERV_VALIDATED}) { - $channel_data->{validated} &= ~$self->{NICKSERV_VALIDATED}; - #$self->{pbot}->{logger}->log("Devalidating account $account\n"); - $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $channel, $channel_data); + if ($mask =~ m/^\$a:(.*)/) { + my $ban_account = lc $1; + @message_accounts = $self->{pbot}->{messagehistory}->{database}->find_message_accounts_by_nickserv($ban_account); + } else { + @message_accounts = $self->{pbot}->{messagehistory}->{database}->find_message_accounts_by_mask($mask); + } + + foreach my $account (@message_accounts) { + my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($account, $channel, 'validated'); + if (defined $channel_data and $channel_data->{validated} & $self->{NICKSERV_VALIDATED}) { + $channel_data->{validated} &= ~$self->{NICKSERV_VALIDATED}; + + #$self->{pbot}->{logger}->log("Devalidating account $account\n"); + $self->{pbot}->{messagehistory}->{database}->update_channel_data($account, $channel, $channel_data); + } } - } } sub check_bans { - my ($self, $message_account, $mask, $channel, $dry_run) = @_; - $channel = lc $channel; + my ($self, $message_account, $mask, $channel, $dry_run) = @_; + $channel = lc $channel; - return if not $self->{pbot}->{chanops}->can_gain_ops($channel); - my $user = $self->{pbot}->{users}->loggedin($channel, $mask); - return if $self->{pbot}->{capabilities}->userhas($user, 'botowner'); + return if not $self->{pbot}->{chanops}->can_gain_ops($channel); + my $user = $self->{pbot}->{users}->loggedin($channel, $mask); + return if $self->{pbot}->{capabilities}->userhas($user, 'botowner'); - my $debug_checkban = $self->{pbot}->{registry}->get_value('antiflood', 'debug_checkban'); + my $debug_checkban = $self->{pbot}->{registry}->get_value('antiflood', 'debug_checkban'); - my $current_nickserv_account = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($message_account); + my $current_nickserv_account = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($message_account); - $self->{pbot}->{logger}->log("anti-flood: [check-bans] checking for bans on $mask " . (defined $current_nickserv_account and length $current_nickserv_account ? "[$current_nickserv_account] " : "") . "in $channel\n"); + $self->{pbot}->{logger}->log("anti-flood: [check-bans] checking for bans on $mask " + . (defined $current_nickserv_account and length $current_nickserv_account ? "[$current_nickserv_account] " : "") + . "in $channel\n"); - my ($do_not_validate, $bans); + my ($do_not_validate, $bans); - if (defined $current_nickserv_account and length $current_nickserv_account) { - $self->{pbot}->{logger}->log("anti-flood: [check-bans] current nickserv [$current_nickserv_account] found for $mask\n") if $debug_checkban >= 2; - my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($message_account, $channel, 'validated'); - if ($channel_data->{validated} & $self->{NEEDS_CHECKBAN}) { - $channel_data->{validated} &= ~$self->{NEEDS_CHECKBAN}; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($message_account, $channel, $channel_data); - } - } else { - if (not exists $self->{pbot}->{irc_capabilities}->{'account-notify'}) { - # mark this account as needing check-bans when nickserv account is identified - my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($message_account, $channel, 'validated'); - if (not $channel_data->{validated} & $self->{NEEDS_CHECKBAN}) { - $channel_data->{validated} |= $self->{NEEDS_CHECKBAN}; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($message_account, $channel, $channel_data); - } - $self->{pbot}->{logger}->log("anti-flood: [check-bans] no account for $mask; marking for later validation\n") if $debug_checkban >= 1; - } else { - $do_not_validate = 1; - } - } - - my ($nick) = $mask =~ m/^([^!]+)/; - my %aliases = $self->{pbot}->{messagehistory}->{database}->get_also_known_as($nick); - - my $csv = Text::CSV->new({binary => 1}); - - foreach my $alias (keys %aliases) { - next if $alias =~ /^Guest\d+(?:!.*)?$/; - - $self->{pbot}->{logger}->log("[after aka] processing $alias\n") if $debug_checkban >= 1; - - if ($aliases{$alias}->{type} == $self->{pbot}->{messagehistory}->{database}->{alias_type}->{WEAK}) { - $self->{pbot}->{logger}->log("anti-flood: [check-bans] skipping WEAK alias $alias in channel $channel\n") if $debug_checkban >= 2; - next; - } - - my @nickservs; - - if (exists $aliases{$alias}->{nickserv}) { - @nickservs = split /,/, $aliases{$alias}->{nickserv}; - } else { - @nickservs = (undef); - } - - foreach my $nickserv (@nickservs) { - my @gecoses; - if (exists $aliases{$alias}->{gecos}) { - $csv->parse($aliases{$alias}->{gecos}); - @gecoses = $csv->fields; - } else { - @gecoses = (undef); - } - - foreach my $gecos (@gecoses) { - my $tgecos = defined $gecos ? $gecos : "[undefined]"; - my $tnickserv = defined $nickserv ? $nickserv : "[undefined]"; - $self->{pbot}->{logger}->log("anti-flood: [check-bans] checking blacklist for $alias in channel $channel using gecos '$tgecos' and nickserv '$tnickserv'\n") if $debug_checkban >= 5; - if ($self->{pbot}->{blacklist}->check_blacklist($alias, $channel, $nickserv, $gecos)) { - my $u = $self->{pbot}->{users}->loggedin($channel, $mask); - if ($self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted')) { - $self->{pbot}->{logger}->log("anti-flood: [check-bans] $mask [$alias] blacklisted in $channel, but allowed through whitelist\n"); - next; - } - - my $baninfo = {}; - $baninfo->{banmask} = $alias; - $baninfo->{channel} = $channel; - $baninfo->{owner} = 'blacklist'; - $baninfo->{when} = 0; - $baninfo->{type} = 'blacklist'; - push @$bans, $baninfo; - next; + if (defined $current_nickserv_account and length $current_nickserv_account) { + $self->{pbot}->{logger}->log("anti-flood: [check-bans] current nickserv [$current_nickserv_account] found for $mask\n") if $debug_checkban >= 2; + my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($message_account, $channel, 'validated'); + if ($channel_data->{validated} & $self->{NEEDS_CHECKBAN}) { + $channel_data->{validated} &= ~$self->{NEEDS_CHECKBAN}; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($message_account, $channel, $channel_data); } - } + } else { + if (not exists $self->{pbot}->{irc_capabilities}->{'account-notify'}) { - $self->{pbot}->{logger}->log("anti-flood: [check-bans] checking for bans in $channel on $alias using nickserv " . (defined $nickserv ? $nickserv : "[undefined]") . "\n") if $debug_checkban >= 2; - my $baninfos = $self->{pbot}->{bantracker}->get_baninfo($alias, $channel, $nickserv); - - if (defined $baninfos) { - foreach my $baninfo (@$baninfos) { - if (time - $baninfo->{when} < 5) { - $self->{pbot}->{logger}->log("anti-flood: [check-bans] $mask [$alias] evaded $baninfo->{banmask} in $baninfo->{channel}, but within 5 seconds of establishing ban; giving another chance\n"); + # mark this account as needing check-bans when nickserv account is identified my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($message_account, $channel, 'validated'); - if ($channel_data->{validated} & $self->{NICKSERV_VALIDATED}) { - $channel_data->{validated} &= ~$self->{NICKSERV_VALIDATED}; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($message_account, $channel, $channel_data); + if (not $channel_data->{validated} & $self->{NEEDS_CHECKBAN}) { + $channel_data->{validated} |= $self->{NEEDS_CHECKBAN}; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($message_account, $channel, $channel_data); } + $self->{pbot}->{logger}->log("anti-flood: [check-bans] no account for $mask; marking for later validation\n") if $debug_checkban >= 1; + } else { $do_not_validate = 1; - next; - } - - my $u = $self->{pbot}->{users}->loggedin($baninfo->{channel}, $mask); - my $whitelisted = $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted'); - if ($self->ban_exempted($baninfo->{channel}, $baninfo->{banmask}) || $whitelisted) { - #$self->{pbot}->{logger}->log("anti-flood: [check-bans] $mask [$alias] evaded $baninfo->{banmask} in $baninfo->{channel}, but allowed through whitelist\n"); - next; - } - - # special case for twkm clone bans - if ($baninfo->{banmask} =~ m/\?\*!\*@\*$/) { - $self->{pbot}->{logger}->log("anti-flood: [check-bans] $mask [$alias] evaded $baninfo->{banmask} in $baninfo->{channel}, but disregarded due to clone ban\n"); - next; - } - - my $banmask_regex = quotemeta $baninfo->{banmask}; - $banmask_regex =~ s/\\\*/.*/g; - $banmask_regex =~ s/\\\?/./g; - - if ($mask =~ /^$banmask_regex$/i) { - $self->{pbot}->{logger}->log("anti-flood: [check-bans] Hostmask ($mask) matches $baninfo->{type} banmask ($banmask_regex), disregarding\n"); - next; - } - - if (defined $nickserv and $baninfo->{type} eq '+q' and $baninfo->{banmask} =~ /^\$a:(.*)/ and lc $1 eq $nickserv and $nickserv eq $current_nickserv_account) { - $self->{pbot}->{logger}->log("anti-flood: [check-bans] Hostmask ($mask) matches quiet on account ($nickserv), disregarding\n"); - next; - } - - if (not defined $bans) { - $bans = []; - } - - $self->{pbot}->{logger}->log("anti-flood: [check-bans] Hostmask ($mask [$alias" . (defined $nickserv ? "/$nickserv" : "") . "]) matches $baninfo->{type} $baninfo->{banmask}, adding ban\n"); - push @$bans, $baninfo; - goto GOT_BAN; } - } } - } + + my ($nick) = $mask =~ m/^([^!]+)/; + my %aliases = $self->{pbot}->{messagehistory}->{database}->get_also_known_as($nick); + + my $csv = Text::CSV->new({binary => 1}); + + foreach my $alias (keys %aliases) { + next if $alias =~ /^Guest\d+(?:!.*)?$/; + + $self->{pbot}->{logger}->log("[after aka] processing $alias\n") if $debug_checkban >= 1; + + if ($aliases{$alias}->{type} == $self->{pbot}->{messagehistory}->{database}->{alias_type}->{WEAK}) { + $self->{pbot}->{logger}->log("anti-flood: [check-bans] skipping WEAK alias $alias in channel $channel\n") if $debug_checkban >= 2; + next; + } + + my @nickservs; + + if (exists $aliases{$alias}->{nickserv}) { @nickservs = split /,/, $aliases{$alias}->{nickserv}; } + else { @nickservs = (undef); } + + foreach my $nickserv (@nickservs) { + my @gecoses; + if (exists $aliases{$alias}->{gecos}) { + $csv->parse($aliases{$alias}->{gecos}); + @gecoses = $csv->fields; + } else { + @gecoses = (undef); + } + + foreach my $gecos (@gecoses) { + my $tgecos = defined $gecos ? $gecos : "[undefined]"; + my $tnickserv = defined $nickserv ? $nickserv : "[undefined]"; + $self->{pbot}->{logger}->log("anti-flood: [check-bans] checking blacklist for $alias in channel $channel using gecos '$tgecos' and nickserv '$tnickserv'\n") + if $debug_checkban >= 5; + if ($self->{pbot}->{blacklist}->check_blacklist($alias, $channel, $nickserv, $gecos)) { + my $u = $self->{pbot}->{users}->loggedin($channel, $mask); + if ($self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted')) { + $self->{pbot}->{logger}->log("anti-flood: [check-bans] $mask [$alias] blacklisted in $channel, but allowed through whitelist\n"); + next; + } + + my $baninfo = {}; + $baninfo->{banmask} = $alias; + $baninfo->{channel} = $channel; + $baninfo->{owner} = 'blacklist'; + $baninfo->{when} = 0; + $baninfo->{type} = 'blacklist'; + push @$bans, $baninfo; + next; + } + } + + $self->{pbot}->{logger}->log("anti-flood: [check-bans] checking for bans in $channel on $alias using nickserv " . (defined $nickserv ? $nickserv : "[undefined]") . "\n") + if $debug_checkban >= 2; + my $baninfos = $self->{pbot}->{bantracker}->get_baninfo($alias, $channel, $nickserv); + + if (defined $baninfos) { + foreach my $baninfo (@$baninfos) { + if (time - $baninfo->{when} < 5) { + $self->{pbot}->{logger} + ->log("anti-flood: [check-bans] $mask [$alias] evaded $baninfo->{banmask} in $baninfo->{channel}, but within 5 seconds of establishing ban; giving another chance\n"); + my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($message_account, $channel, 'validated'); + if ($channel_data->{validated} & $self->{NICKSERV_VALIDATED}) { + $channel_data->{validated} &= ~$self->{NICKSERV_VALIDATED}; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($message_account, $channel, $channel_data); + } + $do_not_validate = 1; + next; + } + + my $u = $self->{pbot}->{users}->loggedin($baninfo->{channel}, $mask); + my $whitelisted = $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted'); + if ($self->ban_exempted($baninfo->{channel}, $baninfo->{banmask}) || $whitelisted) { + + #$self->{pbot}->{logger}->log("anti-flood: [check-bans] $mask [$alias] evaded $baninfo->{banmask} in $baninfo->{channel}, but allowed through whitelist\n"); + next; + } + + # special case for twkm clone bans + if ($baninfo->{banmask} =~ m/\?\*!\*@\*$/) { + $self->{pbot}->{logger}->log("anti-flood: [check-bans] $mask [$alias] evaded $baninfo->{banmask} in $baninfo->{channel}, but disregarded due to clone ban\n"); + next; + } + + my $banmask_regex = quotemeta $baninfo->{banmask}; + $banmask_regex =~ s/\\\*/.*/g; + $banmask_regex =~ s/\\\?/./g; + + if ($mask =~ /^$banmask_regex$/i) { + $self->{pbot}->{logger}->log("anti-flood: [check-bans] Hostmask ($mask) matches $baninfo->{type} banmask ($banmask_regex), disregarding\n"); + next; + } + + if (defined $nickserv and $baninfo->{type} eq '+q' and $baninfo->{banmask} =~ /^\$a:(.*)/ and lc $1 eq $nickserv and $nickserv eq $current_nickserv_account) { + $self->{pbot}->{logger}->log("anti-flood: [check-bans] Hostmask ($mask) matches quiet on account ($nickserv), disregarding\n"); + next; + } + + if (not defined $bans) { $bans = []; } + + $self->{pbot}->{logger} + ->log("anti-flood: [check-bans] Hostmask ($mask [$alias" . (defined $nickserv ? "/$nickserv" : "") . "]) matches $baninfo->{type} $baninfo->{banmask}, adding ban\n"); + push @$bans, $baninfo; + goto GOT_BAN; + } + } + } + } GOT_BAN: - if (defined $bans) { - foreach my $baninfo (@$bans) { - my $banmask; + if (defined $bans) { + foreach my $baninfo (@$bans) { + my $banmask; - my ($user, $host) = $mask =~ m/[^!]+!([^@]+)@(.*)/; - if ($host =~ m{^([^/]+)/.+} and $1 ne 'gateway' and $1 ne 'nat') { - $banmask = "*!*\@$host"; - } elsif ($current_nickserv_account and $baninfo->{banmask} !~ m/^\$a:/i and not exists $self->{pbot}->{bantracker}->{banlist}->{$baninfo->{channel}}->{'+b'}->{"\$a:$current_nickserv_account"}) { - $banmask = "\$a:$current_nickserv_account"; - } else { - if ($host =~ m{^gateway/web/irccloud.com/}) { - $banmask = "*!$user\@gateway/web/irccloud.com/*"; - } elsif ($host =~ m{^nat/([^/]+)/}) { - $banmask = "*!$user\@nat/$1/*"; - } else { - $banmask = "*!*\@$host"; - #$banmask = "*!$user@" . $self->address_to_mask($host); - } - } + my ($user, $host) = $mask =~ m/[^!]+!([^@]+)@(.*)/; + if ($host =~ m{^([^/]+)/.+} and $1 ne 'gateway' and $1 ne 'nat') { $banmask = "*!*\@$host"; } + elsif ( $current_nickserv_account + and $baninfo->{banmask} !~ m/^\$a:/i + and not exists $self->{pbot}->{bantracker}->{banlist}->{$baninfo->{channel}}->{'+b'}->{"\$a:$current_nickserv_account"}) + { + $banmask = "\$a:$current_nickserv_account"; + } else { + if ($host =~ m{^gateway/web/irccloud.com/}) { $banmask = "*!$user\@gateway/web/irccloud.com/*"; } + elsif ($host =~ m{^nat/([^/]+)/}) { $banmask = "*!$user\@nat/$1/*"; } + else { + $banmask = "*!*\@$host"; - $self->{pbot}->{logger}->log("anti-flood: [check-bans] $mask evaded $baninfo->{banmask} banned in $baninfo->{channel} by $baninfo->{owner}, banning $banmask\n"); - my ($bannick) = $mask =~ m/^([^!]+)/; - if ($self->{pbot}->{registry}->get_value('antiflood', 'enforce')) { - if ($self->{pbot}->{chanops}->has_ban_timeout($baninfo->{channel}, $banmask)) { - $self->{pbot}->{logger}->log("anti-flood: [check-bans] $banmask already banned in $channel, disregarding\n"); - return; - } + #$banmask = "*!$user@" . $self->address_to_mask($host); + } + } - my $ancestor = $self->{pbot}->{messagehistory}->{database}->get_ancestor_id($message_account); - if (exists $self->{nickflood}->{$ancestor} and $self->{nickflood}->{$ancestor}->{offenses} > 0 and $baninfo->{type} ne 'blacklist') { - if (gettimeofday - $self->{nickflood}->{$ancestor}->{timestamp} < 60 * 15) { - $self->{pbot}->{logger}->log("anti-flood: [check-bans] $mask evading nick-flood ban, disregarding\n"); + $self->{pbot}->{logger}->log("anti-flood: [check-bans] $mask evaded $baninfo->{banmask} banned in $baninfo->{channel} by $baninfo->{owner}, banning $banmask\n"); + my ($bannick) = $mask =~ m/^([^!]+)/; + if ($self->{pbot}->{registry}->get_value('antiflood', 'enforce')) { + if ($self->{pbot}->{chanops}->has_ban_timeout($baninfo->{channel}, $banmask)) { + $self->{pbot}->{logger}->log("anti-flood: [check-bans] $banmask already banned in $channel, disregarding\n"); + return; + } + + my $ancestor = $self->{pbot}->{messagehistory}->{database}->get_ancestor_id($message_account); + if (exists $self->{nickflood}->{$ancestor} and $self->{nickflood}->{$ancestor}->{offenses} > 0 and $baninfo->{type} ne 'blacklist') { + if (gettimeofday - $self->{nickflood}->{$ancestor}->{timestamp} < 60 * 15) { + $self->{pbot}->{logger}->log("anti-flood: [check-bans] $mask evading nick-flood ban, disregarding\n"); + return; + } + } + + if (defined $dry_run && $dry_run != 0) { + $self->{pbot}->{logger}->log("Skipping ban due to dry-run.\n"); + return; + } + + if ($baninfo->{type} eq 'blacklist') { $self->{pbot}->{chanops}->add_op_command($baninfo->{channel}, "kick $baninfo->{channel} $bannick I don't think so"); } + else { + my $owner = $baninfo->{owner}; + $owner =~ s/!.*$//; + $self->{pbot}->{chanops}->add_op_command($baninfo->{channel}, "kick $baninfo->{channel} $bannick Evaded $baninfo->{banmask} set by $owner"); + } + $self->{pbot}->{chanops}->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'ban evasion', $banmask, $baninfo->{channel}, 60 * 60 * 24 * 14); + } + my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($message_account, $channel, 'validated'); + if ($channel_data->{validated} & $self->{NICKSERV_VALIDATED}) { + $channel_data->{validated} &= ~$self->{NICKSERV_VALIDATED}; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($message_account, $channel, $channel_data); + } return; - } } - - if (defined $dry_run && $dry_run != 0) { - $self->{pbot}->{logger}->log("Skipping ban due to dry-run.\n"); - return; - } - - if ($baninfo->{type} eq 'blacklist') { - $self->{pbot}->{chanops}->add_op_command($baninfo->{channel}, "kick $baninfo->{channel} $bannick I don't think so"); - } else { - my $owner = $baninfo->{owner}; - $owner =~ s/!.*$//; - $self->{pbot}->{chanops}->add_op_command($baninfo->{channel}, "kick $baninfo->{channel} $bannick Evaded $baninfo->{banmask} set by $owner"); - } - $self->{pbot}->{chanops}->ban_user_timed($self->{pbot}->{registry}->get_value('irc', 'botnick'), 'ban evasion', $banmask, $baninfo->{channel}, 60 * 60 * 24 * 14); - } - my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($message_account, $channel, 'validated'); - if ($channel_data->{validated} & $self->{NICKSERV_VALIDATED}) { - $channel_data->{validated} &= ~$self->{NICKSERV_VALIDATED}; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($message_account, $channel, $channel_data); - } - return; } - } - unless ($do_not_validate) { - my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($message_account, $channel, 'validated'); - if (not $channel_data->{validated} & $self->{NICKSERV_VALIDATED}) { - $channel_data->{validated} |= $self->{NICKSERV_VALIDATED}; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($message_account, $channel, $channel_data); + unless ($do_not_validate) { + my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($message_account, $channel, 'validated'); + if (not $channel_data->{validated} & $self->{NICKSERV_VALIDATED}) { + $channel_data->{validated} |= $self->{NICKSERV_VALIDATED}; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($message_account, $channel, $channel_data); + } } - } } sub check_nickserv_accounts { - my ($self, $nick, $account, $hostmask) = @_; - my $message_account; + my ($self, $nick, $account, $hostmask) = @_; + my $message_account; - #$self->{pbot}->{logger}->log("Checking nickserv accounts for nick $nick with account $account and hostmask " . (defined $hostmask ? $hostmask : 'undef') . "\n"); + #$self->{pbot}->{logger}->log("Checking nickserv accounts for nick $nick with account $account and hostmask " . (defined $hostmask ? $hostmask : 'undef') . "\n"); - $account = lc $account; + $account = lc $account; - if (not defined $hostmask) { - ($message_account, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick); + if (not defined $hostmask) { + ($message_account, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick); - if (not defined $message_account) { - $self->{pbot}->{logger}->log("No message account found for nick $nick.\n"); - ($message_account) = $self->{pbot}->{messagehistory}->{database}->find_message_accounts_by_nickserv($account); + if (not defined $message_account) { + $self->{pbot}->{logger}->log("No message account found for nick $nick.\n"); + ($message_account) = $self->{pbot}->{messagehistory}->{database}->find_message_accounts_by_nickserv($account); - if (not $message_account) { - $self->{pbot}->{logger}->log("No message account found for nickserv $account.\n"); - return; - } + if (not $message_account) { + $self->{pbot}->{logger}->log("No message account found for nickserv $account.\n"); + return; + } + } + } else { + ($message_account) = $self->{pbot}->{messagehistory}->{database}->find_message_accounts_by_mask($hostmask); + if (not $message_account) { + $self->{pbot}->{logger}->log("No message account found for hostmask $hostmask.\n"); + return; + } } - } else { - ($message_account) = $self->{pbot}->{messagehistory}->{database}->find_message_accounts_by_mask($hostmask); - if (not $message_account) { - $self->{pbot}->{logger}->log("No message account found for hostmask $hostmask.\n"); - return; - } - } - #$self->{pbot}->{logger}->log("anti-flood: $message_account: setting nickserv account to [$account]\n"); - $self->{pbot}->{messagehistory}->{database}->update_nickserv_account($message_account, $account, scalar gettimeofday); - $self->{pbot}->{messagehistory}->{database}->set_current_nickserv_account($message_account, $account); + #$self->{pbot}->{logger}->log("anti-flood: $message_account: setting nickserv account to [$account]\n"); + $self->{pbot}->{messagehistory}->{database}->update_nickserv_account($message_account, $account, scalar gettimeofday); + $self->{pbot}->{messagehistory}->{database}->set_current_nickserv_account($message_account, $account); } sub on_endofwhois { - my ($self, $event_type, $event) = @_; - my $nick = $event->{event}->{args}[1]; + my ($self, $event_type, $event) = @_; + my $nick = $event->{event}->{args}[1]; - delete $self->{whois_pending}->{$nick}; + delete $self->{whois_pending}->{$nick}; - my ($id, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick); - # $self->{pbot}->{logger}->log("endofwhois: Found [$id][$hostmask] for [$nick]\n"); - $self->{pbot}->{messagehistory}->{database}->link_aliases($id, $hostmask) if $id; + my ($id, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick); - # check to see if any channels need check-ban validation - my $channels = $self->{pbot}->{nicklist}->get_channels($nick); - foreach my $channel (@$channels) { - next unless $channel =~ /^#/; - my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($id, $channel, 'validated'); - if ($channel_data->{validated} & $self->{NEEDS_CHECKBAN} or not $channel_data->{validated} & $self->{NICKSERV_VALIDATED}) { - $self->check_bans($id, $hostmask, $channel); + # $self->{pbot}->{logger}->log("endofwhois: Found [$id][$hostmask] for [$nick]\n"); + $self->{pbot}->{messagehistory}->{database}->link_aliases($id, $hostmask) if $id; + + # check to see if any channels need check-ban validation + my $channels = $self->{pbot}->{nicklist}->get_channels($nick); + foreach my $channel (@$channels) { + next unless $channel =~ /^#/; + my $channel_data = $self->{pbot}->{messagehistory}->{database}->get_channel_data($id, $channel, 'validated'); + if ($channel_data->{validated} & $self->{NEEDS_CHECKBAN} or not $channel_data->{validated} & $self->{NICKSERV_VALIDATED}) { $self->check_bans($id, $hostmask, $channel); } } - } - return 0; + return 0; } sub on_whoisuser { - my ($self, $event_type, $event) = @_; - my $nick = $event->{event}->{args}[1]; - my $gecos = lc $event->{event}->{args}[5]; + my ($self, $event_type, $event) = @_; + my $nick = $event->{event}->{args}[1]; + my $gecos = lc $event->{event}->{args}[5]; - my ($id) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick); + my ($id) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick); - if ($self->{pbot}->{registry}->get_value('antiflood', 'debug_checkban') >= 2) { - $self->{pbot}->{logger}->log("Got gecos for $nick ($id): '$gecos'\n"); - } + if ($self->{pbot}->{registry}->get_value('antiflood', 'debug_checkban') >= 2) { $self->{pbot}->{logger}->log("Got gecos for $nick ($id): '$gecos'\n"); } - $self->{pbot}->{messagehistory}->{database}->update_gecos($id, $gecos, scalar gettimeofday); + $self->{pbot}->{messagehistory}->{database}->update_gecos($id, $gecos, scalar gettimeofday); } sub on_whoisaccount { - my ($self, $event_type, $event) = @_; - my $nick = $event->{event}->{args}[1]; - my $account = lc $event->{event}->{args}[2]; + my ($self, $event_type, $event) = @_; + my $nick = $event->{event}->{args}[1]; + my $account = lc $event->{event}->{args}[2]; - if ($self->{pbot}->{registry}->get_value('antiflood', 'debug_checkban')) { - $self->{pbot}->{logger}->log("$nick is using NickServ account [$account]\n"); - } + if ($self->{pbot}->{registry}->get_value('antiflood', 'debug_checkban')) { $self->{pbot}->{logger}->log("$nick is using NickServ account [$account]\n"); } - my ($id, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick); - # $self->{pbot}->{logger}->log("whoisaccount: Found [$id][$hostmask][$account] for [$nick]\n"); - $self->{pbot}->{messagehistory}->{database}->link_aliases($id, undef, $account) if $id; + my ($id, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick); - $self->check_nickserv_accounts($nick, $account); + # $self->{pbot}->{logger}->log("whoisaccount: Found [$id][$hostmask][$account] for [$nick]\n"); + $self->{pbot}->{messagehistory}->{database}->link_aliases($id, undef, $account) if $id; - return 0; + $self->check_nickserv_accounts($nick, $account); + + return 0; } sub on_accountnotify { - my ($self, $event_type, $event) = @_; + my ($self, $event_type, $event) = @_; - $self->{pbot}->{messagehistory}->{database}->update_hostmask_data($event->{event}->{from}, { last_seen => scalar gettimeofday }); + $self->{pbot}->{messagehistory}->{database}->update_hostmask_data($event->{event}->{from}, {last_seen => scalar gettimeofday}); - if ($event->{event}->{args}[0] eq '*') { - $self->{pbot}->{logger}->log("$event->{event}->{from} logged out of NickServ\n"); - my ($nick, $user, $host) = $event->{event}->{from} =~ m/^([^!]+)!([^@]+)@(.*)/; - my $message_account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - $self->{pbot}->{messagehistory}->{database}->set_current_nickserv_account($message_account, ''); - } else { - $self->{pbot}->{logger}->log("$event->{event}->{from} logged into NickServ account $event->{event}->{args}[0]\n"); + if ($event->{event}->{args}[0] eq '*') { + $self->{pbot}->{logger}->log("$event->{event}->{from} logged out of NickServ\n"); + my ($nick, $user, $host) = $event->{event}->{from} =~ m/^([^!]+)!([^@]+)@(.*)/; + my $message_account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + $self->{pbot}->{messagehistory}->{database}->set_current_nickserv_account($message_account, ''); + } else { + $self->{pbot}->{logger}->log("$event->{event}->{from} logged into NickServ account $event->{event}->{args}[0]\n"); - my $nick = $event->{event}->nick; - my ($id, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick); - $self->{pbot}->{messagehistory}->{database}->link_aliases($id, undef, $event->{event}->{args}[0]) if $id; - $self->check_nickserv_accounts($nick, $event->{event}->{args}[0]); + my $nick = $event->{event}->nick; + my ($id, $hostmask) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($nick); + $self->{pbot}->{messagehistory}->{database}->link_aliases($id, undef, $event->{event}->{args}[0]) if $id; + $self->check_nickserv_accounts($nick, $event->{event}->{args}[0]); - $self->{pbot}->{messagehistory}->{database}->devalidate_all_channels($id); + $self->{pbot}->{messagehistory}->{database}->devalidate_all_channels($id); - my $channels = $self->{pbot}->{nicklist}->get_channels($nick); - foreach my $channel (@$channels) { - next unless $channel =~ /^#/; - $self->check_bans($id, $hostmask, $channel); + my $channels = $self->{pbot}->{nicklist}->get_channels($nick); + foreach my $channel (@$channels) { + next unless $channel =~ /^#/; + $self->check_bans($id, $hostmask, $channel); + } } - } - return 0; + return 0; } sub adjust_offenses { - my $self = shift; + my $self = shift; - #$self->{pbot}->{logger}->log("Adjusting offenses . . .\n"); + #$self->{pbot}->{logger}->log("Adjusting offenses . . .\n"); - # decrease offenses counter if 24 hours have elapsed since latest offense - my $channel_datas = $self->{pbot}->{messagehistory}->{database}->get_channel_datas_where_last_offense_older_than(gettimeofday - 60 * 60 * 24); - foreach my $channel_data (@$channel_datas) { - my $id = delete $channel_data->{id}; - my $channel = delete $channel_data->{channel}; - my $update = 0; + # decrease offenses counter if 24 hours have elapsed since latest offense + my $channel_datas = $self->{pbot}->{messagehistory}->{database}->get_channel_datas_where_last_offense_older_than(gettimeofday - 60 * 60 * 24); + foreach my $channel_data (@$channel_datas) { + my $id = delete $channel_data->{id}; + my $channel = delete $channel_data->{channel}; + my $update = 0; - if ($channel_data->{offenses} > 0) { - $channel_data->{offenses}--; - $update = 1; + if ($channel_data->{offenses} > 0) { + $channel_data->{offenses}--; + $update = 1; + } + + if (defined $channel_data->{unbanmes} and $channel_data->{unbanmes} > 0) { + $channel_data->{unbanmes}--; + $update = 1; + } + + if ($update) { + $channel_data->{last_offense} = gettimeofday; + $self->{pbot}->{messagehistory}->{database}->update_channel_data($id, $channel, $channel_data); + } } - if (defined $channel_data->{unbanmes} and $channel_data->{unbanmes} > 0) { - $channel_data->{unbanmes}--; - $update = 1; + $channel_datas = $self->{pbot}->{messagehistory}->{database}->get_channel_datas_with_enter_abuses(); + foreach my $channel_data (@$channel_datas) { + my $id = delete $channel_data->{id}; + my $channel = delete $channel_data->{channel}; + my $last_offense = delete $channel_data->{last_offense}; + if (gettimeofday - $last_offense >= 60 * 60 * 3) { + $channel_data->{enter_abuses}--; + + #$self->{pbot}->{logger}->log("[adjust-offenses] [$id][$channel] decreasing enter abuse offenses to $channel_data->{enter_abuses}\n"); + $self->{pbot}->{messagehistory}->{database}->update_channel_data($id, $channel, $channel_data); + } } - if ($update) { - $channel_data->{last_offense} = gettimeofday; - $self->{pbot}->{messagehistory}->{database}->update_channel_data($id, $channel, $channel_data); - } - } + foreach my $account (keys %{$self->{nickflood}}) { + if ($self->{nickflood}->{$account}->{offenses} and gettimeofday - $self->{nickflood}->{$account}->{timestamp} >= 60 * 60) { + $self->{nickflood}->{$account}->{offenses}--; - $channel_datas = $self->{pbot}->{messagehistory}->{database}->get_channel_datas_with_enter_abuses(); - foreach my $channel_data (@$channel_datas) { - my $id = delete $channel_data->{id}; - my $channel = delete $channel_data->{channel}; - my $last_offense = delete $channel_data->{last_offense}; - if (gettimeofday - $last_offense >= 60 * 60 * 3) { - $channel_data->{enter_abuses}--; - #$self->{pbot}->{logger}->log("[adjust-offenses] [$id][$channel] decreasing enter abuse offenses to $channel_data->{enter_abuses}\n"); - $self->{pbot}->{messagehistory}->{database}->update_channel_data($id, $channel, $channel_data); + if ($self->{nickflood}->{$account}->{offenses} <= 0) { delete $self->{nickflood}->{$account}; } + else { $self->{nickflood}->{$account}->{timestamp} = gettimeofday; } + } } - } - - foreach my $account (keys %{ $self->{nickflood} }) { - if ($self->{nickflood}->{$account}->{offenses} and gettimeofday - $self->{nickflood}->{$account}->{timestamp} >= 60 * 60) { - $self->{nickflood}->{$account}->{offenses}--; - - if ($self->{nickflood}->{$account}->{offenses} <= 0) { - delete $self->{nickflood}->{$account}; - } else { - $self->{nickflood}->{$account}->{timestamp} = gettimeofday; - } - } - } } 1; diff --git a/PBot/AntiSpam.pm b/PBot/AntiSpam.pm index 8b0082b8..289135a2 100644 --- a/PBot/AntiSpam.pm +++ b/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 , where commands are: list/show, add, remove, set, unset" if not defined $command; + return "Usage: antispam , 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 [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 [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 " 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 " 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 " 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 " 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 " 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 " 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; diff --git a/PBot/BanTracker.pm b/PBot/BanTracker.pm index 0d0f1ee6..8a75e76a 100644 --- a/PBot/BanTracker.pm +++ b/PBot/BanTracker.pm @@ -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; diff --git a/PBot/BlackList.pm b/PBot/BlackList.pm index 6c35a242..ff386cc9 100644 --- a/PBot/BlackList.pm +++ b/PBot/BlackList.pm @@ -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 = ; - 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 = ; + 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"; } } } diff --git a/PBot/Capabilities.pm b/PBot/Capabilities.pm index a1b08c6d..8098e50b 100644 --- a/PBot/Capabilities.pm +++ b/PBot/Capabilities.pm @@ -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 ; Lists all users who have " 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 ; Lists all users who have " 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 [capability]; Lists capabilities belonging to " 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 [capability]; Lists capabilities belonging to " 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 " 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 " 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 | cap ungroup | cap userhas [capability] | cap whohas "; } - return $result; - } } - - when ('group') { - my ($cap, $subcaps) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); - return "Usage: cap group " 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 " 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 | cap ungroup | cap userhas [capability] | cap whohas "; - } - } - return $result; + return $result; } 1; diff --git a/PBot/ChanOpCommands.pm b/PBot/ChanOpCommands.pm index d3cc438c..fbd0a367 100644 --- a/PBot/ChanOpCommands.pm +++ b/PBot/ChanOpCommands.pm @@ -8,6 +8,7 @@ # file, You can obtain one at http://mozilla.org/MPL/2.0/. package PBot::ChanOpCommands; + use parent 'PBot::Class'; use warnings; use strict; @@ -17,720 +18,684 @@ use Time::Duration; use Time::HiRes qw/gettimeofday/; sub initialize { - my ($self, %conf) = @_; - # register commands - $self->{pbot}->{commands}->register(sub { $self->ban_user(@_) }, "ban", 1); - $self->{pbot}->{commands}->register(sub { $self->unban_user(@_) }, "unban", 1); - $self->{pbot}->{commands}->register(sub { $self->mute_user(@_) }, "mute", 1); - $self->{pbot}->{commands}->register(sub { $self->unmute_user(@_) }, "unmute", 1); - $self->{pbot}->{commands}->register(sub { $self->kick_user(@_) }, "kick", 1); - $self->{pbot}->{commands}->register(sub { $self->checkban(@_) }, "checkban", 0); - $self->{pbot}->{commands}->register(sub { $self->checkmute(@_) }, "checkmute", 0); - $self->{pbot}->{commands}->register(sub { $self->op_user(@_) }, "op", 1); - $self->{pbot}->{commands}->register(sub { $self->deop_user(@_) }, "deop", 1); - $self->{pbot}->{commands}->register(sub { $self->voice_user(@_) }, "voice", 1); - $self->{pbot}->{commands}->register(sub { $self->devoice_user(@_) }, "devoice", 1); - $self->{pbot}->{commands}->register(sub { $self->mode(@_) }, "mode", 1); - $self->{pbot}->{commands}->register(sub { $self->invite(@_) }, "invite", 1); + my ($self, %conf) = @_; - # allow commands to set modes - $self->{pbot}->{capabilities}->add('can-ban', 'can-mode-b', 1); - $self->{pbot}->{capabilities}->add('can-unban', 'can-mode-b', 1); - $self->{pbot}->{capabilities}->add('can-mute', 'can-mode-q', 1); - $self->{pbot}->{capabilities}->add('can-unmute', 'can-mode-q', 1); - $self->{pbot}->{capabilities}->add('can-op', 'can-mode-o', 1); - $self->{pbot}->{capabilities}->add('can-deop', 'can-mode-o', 1); - $self->{pbot}->{capabilities}->add('can-voice', 'can-mode-v', 1); - $self->{pbot}->{capabilities}->add('can-devoice', 'can-mode-v', 1); + # register commands + $self->{pbot}->{commands}->register(sub { $self->ban_user(@_) }, "ban", 1); + $self->{pbot}->{commands}->register(sub { $self->unban_user(@_) }, "unban", 1); + $self->{pbot}->{commands}->register(sub { $self->mute_user(@_) }, "mute", 1); + $self->{pbot}->{commands}->register(sub { $self->unmute_user(@_) }, "unmute", 1); + $self->{pbot}->{commands}->register(sub { $self->kick_user(@_) }, "kick", 1); + $self->{pbot}->{commands}->register(sub { $self->checkban(@_) }, "checkban", 0); + $self->{pbot}->{commands}->register(sub { $self->checkmute(@_) }, "checkmute", 0); + $self->{pbot}->{commands}->register(sub { $self->op_user(@_) }, "op", 1); + $self->{pbot}->{commands}->register(sub { $self->deop_user(@_) }, "deop", 1); + $self->{pbot}->{commands}->register(sub { $self->voice_user(@_) }, "voice", 1); + $self->{pbot}->{commands}->register(sub { $self->devoice_user(@_) }, "devoice", 1); + $self->{pbot}->{commands}->register(sub { $self->mode(@_) }, "mode", 1); + $self->{pbot}->{commands}->register(sub { $self->invite(@_) }, "invite", 1); - # create can-mode-any capabilities group - foreach my $mode ("a" .. "z", "A" .. "Z") { - $self->{pbot}->{capabilities}->add('can-mode-any', "can-mode-$mode", 1); - } - $self->{pbot}->{capabilities}->add('can-mode-any', 'can-mode', 1); + # allow commands to set modes + $self->{pbot}->{capabilities}->add('can-ban', 'can-mode-b', 1); + $self->{pbot}->{capabilities}->add('can-unban', 'can-mode-b', 1); + $self->{pbot}->{capabilities}->add('can-mute', 'can-mode-q', 1); + $self->{pbot}->{capabilities}->add('can-unmute', 'can-mode-q', 1); + $self->{pbot}->{capabilities}->add('can-op', 'can-mode-o', 1); + $self->{pbot}->{capabilities}->add('can-deop', 'can-mode-o', 1); + $self->{pbot}->{capabilities}->add('can-voice', 'can-mode-v', 1); + $self->{pbot}->{capabilities}->add('can-devoice', 'can-mode-v', 1); - # add to chanop capabilities group - $self->{pbot}->{capabilities}->add('chanop', 'can-ban', 1); - $self->{pbot}->{capabilities}->add('chanop', 'can-unban', 1); - $self->{pbot}->{capabilities}->add('chanop', 'can-mute', 1); - $self->{pbot}->{capabilities}->add('chanop', 'can-unmute', 1); - $self->{pbot}->{capabilities}->add('chanop', 'can-kick', 1); - $self->{pbot}->{capabilities}->add('chanop', 'can-op', 1); - $self->{pbot}->{capabilities}->add('chanop', 'can-deop', 1); - $self->{pbot}->{capabilities}->add('chanop', 'can-voice', 1); - $self->{pbot}->{capabilities}->add('chanop', 'can-devoice', 1); - $self->{pbot}->{capabilities}->add('chanop', 'can-invite', 1); - $self->{pbot}->{capabilities}->add('chanop', 'is-whitelisted', 1); + # create can-mode-any capabilities group + foreach my $mode ("a" .. "z", "A" .. "Z") { $self->{pbot}->{capabilities}->add('can-mode-any', "can-mode-$mode", 1); } + $self->{pbot}->{capabilities}->add('can-mode-any', 'can-mode', 1); - # add to admin capability group - $self->{pbot}->{capabilities}->add('admin', 'chanop', 1); - $self->{pbot}->{capabilities}->add('admin', 'can-mode', 1); - $self->{pbot}->{capabilities}->add('admin', 'can-mode-any', 1); + # add to chanop capabilities group + $self->{pbot}->{capabilities}->add('chanop', 'can-ban', 1); + $self->{pbot}->{capabilities}->add('chanop', 'can-unban', 1); + $self->{pbot}->{capabilities}->add('chanop', 'can-mute', 1); + $self->{pbot}->{capabilities}->add('chanop', 'can-unmute', 1); + $self->{pbot}->{capabilities}->add('chanop', 'can-kick', 1); + $self->{pbot}->{capabilities}->add('chanop', 'can-op', 1); + $self->{pbot}->{capabilities}->add('chanop', 'can-deop', 1); + $self->{pbot}->{capabilities}->add('chanop', 'can-voice', 1); + $self->{pbot}->{capabilities}->add('chanop', 'can-devoice', 1); + $self->{pbot}->{capabilities}->add('chanop', 'can-invite', 1); + $self->{pbot}->{capabilities}->add('chanop', 'is-whitelisted', 1); - # allow users to use !unban * or !unmute * - $self->{pbot}->{capabilities}->add('can-clear-bans', undef, 1); - $self->{pbot}->{capabilities}->add('can-clear-mutes', undef, 1); + # add to admin capability group + $self->{pbot}->{capabilities}->add('admin', 'chanop', 1); + $self->{pbot}->{capabilities}->add('admin', 'can-mode', 1); + $self->{pbot}->{capabilities}->add('admin', 'can-mode-any', 1); - # allow admins to use !unban * or !unmute * - $self->{pbot}->{capabilities}->add('admin', 'can-clear-bans', 1); - $self->{pbot}->{capabilities}->add('admin', 'can-clear-mutes', 1); + # allow users to use !unban * or !unmute * + $self->{pbot}->{capabilities}->add('can-clear-bans', undef, 1); + $self->{pbot}->{capabilities}->add('can-clear-mutes', undef, 1); - # allows users to use wildcards in command - $self->{pbot}->{capabilities}->add('can-op-wildcard', undef, 1); - $self->{pbot}->{capabilities}->add('can-voice-wildcard', undef, 1); - $self->{pbot}->{capabilities}->add('can-kick-wildcard', undef, 1); + # allow admins to use !unban * or !unmute * + $self->{pbot}->{capabilities}->add('admin', 'can-clear-bans', 1); + $self->{pbot}->{capabilities}->add('admin', 'can-clear-mutes', 1); - $self->{pbot}->{capabilities}->add('admin', 'can-kick-wildcard', 1); - $self->{pbot}->{capabilities}->add('admin', 'can-op-wildcard', 1); - $self->{pbot}->{capabilities}->add('admin', 'can-voice-wildcard', 1); - $self->{pbot}->{capabilities}->add('chanmod', 'can-voice-wildcard', 1); + # allows users to use wildcards in command + $self->{pbot}->{capabilities}->add('can-op-wildcard', undef, 1); + $self->{pbot}->{capabilities}->add('can-voice-wildcard', undef, 1); + $self->{pbot}->{capabilities}->add('can-kick-wildcard', undef, 1); - $self->{invites} = {}; # track who invited who in order to direct invite responses to them + $self->{pbot}->{capabilities}->add('admin', 'can-kick-wildcard', 1); + $self->{pbot}->{capabilities}->add('admin', 'can-op-wildcard', 1); + $self->{pbot}->{capabilities}->add('admin', 'can-voice-wildcard', 1); + $self->{pbot}->{capabilities}->add('chanmod', 'can-voice-wildcard', 1); - # handle invite responses - $self->{pbot}->{event_dispatcher}->register_handler('irc.inviting', sub { $self->on_inviting(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.useronchannel', sub { $self->on_useronchannel(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.nosuchnick', sub { $self->on_nosuchnick(@_) }); + $self->{invites} = {}; # track who invited who in order to direct invite responses to them + + # handle invite responses + $self->{pbot}->{event_dispatcher}->register_handler('irc.inviting', sub { $self->on_inviting(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.useronchannel', sub { $self->on_useronchannel(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.nosuchnick', sub { $self->on_nosuchnick(@_) }); } sub on_inviting { - my ($self, $event_type, $event) = @_; - my ($botnick, $target, $channel) = $event->{event}->args; - $self->{pbot}->{logger}->log("User $target invited to channel $channel.\n"); - return 0 if not exists $self->{invites}->{lc $channel} or not exists $self->{invites}->{lc $channel}->{lc $target}; - $event->{conn}->privmsg($self->{invites}->{lc $channel}->{lc $target}, "$target invited to $channel."); - delete $self->{invites}->{lc $channel}->{lc $target}; - return 1; + my ($self, $event_type, $event) = @_; + my ($botnick, $target, $channel) = $event->{event}->args; + $self->{pbot}->{logger}->log("User $target invited to channel $channel.\n"); + return 0 if not exists $self->{invites}->{lc $channel} or not exists $self->{invites}->{lc $channel}->{lc $target}; + $event->{conn}->privmsg($self->{invites}->{lc $channel}->{lc $target}, "$target invited to $channel."); + delete $self->{invites}->{lc $channel}->{lc $target}; + return 1; } sub on_useronchannel { - my ($self, $event_type, $event) = @_; - my ($botnick, $target, $channel) = $event->{event}->args; - $self->{pbot}->{logger}->log("User $target is already on channel $channel.\n"); - return 0 if not exists $self->{invites}->{lc $channel} or not exists $self->{invites}->{lc $channel}->{lc $target}; - $event->{conn}->privmsg($self->{invites}->{lc $channel}->{lc $target}, "$target is already on $channel."); - delete $self->{invites}->{lc $channel}->{lc $target}; - return 1; + my ($self, $event_type, $event) = @_; + my ($botnick, $target, $channel) = $event->{event}->args; + $self->{pbot}->{logger}->log("User $target is already on channel $channel.\n"); + return 0 if not exists $self->{invites}->{lc $channel} or not exists $self->{invites}->{lc $channel}->{lc $target}; + $event->{conn}->privmsg($self->{invites}->{lc $channel}->{lc $target}, "$target is already on $channel."); + delete $self->{invites}->{lc $channel}->{lc $target}; + return 1; } sub on_nosuchnick { - my ($self, $event_type, $event) = @_; - my ($botnick, $target, $msg) = $event->{event}->args; + my ($self, $event_type, $event) = @_; + my ($botnick, $target, $msg) = $event->{event}->args; - $self->{pbot}->{logger}->log("$target: $msg\n"); + $self->{pbot}->{logger}->log("$target: $msg\n"); - my $nick; - foreach my $channel (keys %{$self->{invites}}) { - if (exists $self->{invites}->{$channel}->{lc $target}) { - $nick = $self->{invites}->{$channel}->{lc $target}; - delete $self->{invites}->{$channel}->{lc $target}; - last; + my $nick; + foreach my $channel (keys %{$self->{invites}}) { + if (exists $self->{invites}->{$channel}->{lc $target}) { + $nick = $self->{invites}->{$channel}->{lc $target}; + delete $self->{invites}->{$channel}->{lc $target}; + last; + } } - } - return 0 if not defined $nick; - $event->{conn}->privmsg($nick, "$target: $msg"); - return 1; + return 0 if not defined $nick; + $event->{conn}->privmsg($nick, "$target: $msg"); + return 1; } sub invite { - my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; - my ($channel, $target); + my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; + my ($channel, $target); - if ($from !~ m/^#/) { - # from /msg - my $usage = "Usage from /msg: invite [nick]; if you omit [nick] then you will be invited"; - return $usage if not length $arguments; - ($channel, $target) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); - return "$channel is not a channel; $usage" if $channel !~ m/^#/; - $target = $nick if not defined $target; - } else { - # in channel - return "Usage: invite [channel] " if not length $arguments; - # add current channel as default channel - $self->{pbot}->{interpreter}->unshift_arg($stuff->{arglist}, $from) if $stuff->{arglist}[0] !~ m/^#/; - ($channel, $target) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); - } + if ($from !~ m/^#/) { - $self->{invites}->{lc $channel}->{lc $target} = $nick; - $self->{pbot}->{chanops}->add_op_command($channel, "sl invite $target $channel"); - $self->{pbot}->{chanops}->gain_ops($channel); - return ""; # responses handled by events + # from /msg + my $usage = "Usage from /msg: invite [nick]; if you omit [nick] then you will be invited"; + return $usage if not length $arguments; + ($channel, $target) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); + return "$channel is not a channel; $usage" if $channel !~ m/^#/; + $target = $nick if not defined $target; + } else { + + # in channel + return "Usage: invite [channel] " if not length $arguments; + + # add current channel as default channel + $self->{pbot}->{interpreter}->unshift_arg($stuff->{arglist}, $from) if $stuff->{arglist}[0] !~ m/^#/; + ($channel, $target) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); + } + + $self->{invites}->{lc $channel}->{lc $target} = $nick; + $self->{pbot}->{chanops}->add_op_command($channel, "sl invite $target $channel"); + $self->{pbot}->{chanops}->gain_ops($channel); + return ""; # responses handled by events } sub generic_mode_user { - my ($self, $mode_flag, $mode_name, $channel, $nick, $stuff) = @_; - my $result = ''; + my ($self, $mode_flag, $mode_name, $channel, $nick, $stuff) = @_; + my $result = ''; - my ($flag, $mode_char) = $mode_flag =~ m/(.)(.)/; + my ($flag, $mode_char) = $mode_flag =~ m/(.)(.)/; - if ($channel !~ m/^#/) { - # from message - $channel = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}); - if (not defined $channel) { - return "Usage from message: $mode_name [nick]"; - } elsif ($channel !~ m/^#/) { - return "$channel is not a channel. Usage from message: $mode_name [nick]"; + if ($channel !~ m/^#/) { + + # from message + $channel = $self->{pbot}->{interpreter}->shift_arg($stuff->{arglist}); + if (not defined $channel) { return "Usage from message: $mode_name [nick]"; } + elsif ($channel !~ m/^#/) { return "$channel is not a channel. Usage from message: $mode_name [nick]"; } } - } - $channel = lc $channel; - if (not $self->{pbot}->{chanops}->can_gain_ops($channel)) { - return "I am not configured as an OP for $channel. See `chanset` command for more information."; - } + $channel = lc $channel; + if (not $self->{pbot}->{chanops}->can_gain_ops($channel)) { return "I am not configured as an OP for $channel. See `chanset` command for more information."; } - # add $nick to $args if no argument - if (not $self->{pbot}->{interpreter}->arglist_size($stuff->{arglist})) { - $self->{pbot}->{interpreter}->unshift_arg($stuff->{arglist}, $nick); - } + # add $nick to $args if no argument + if (not $self->{pbot}->{interpreter}->arglist_size($stuff->{arglist})) { $self->{pbot}->{interpreter}->unshift_arg($stuff->{arglist}, $nick); } - my $max_modes = $self->{pbot}->{ircd}->{MODES} // 1; - my $mode = $flag; - my $list = ''; - my $i = 0; + my $max_modes = $self->{pbot}->{ircd}->{MODES} // 1; + my $mode = $flag; + my $list = ''; + my $i = 0; - foreach my $targets ($self->{pbot}->{interpreter}->unquoted_args($stuff->{arglist})) { - foreach my $target (split /,/, $targets) { - $mode .= $mode_char; - $list .= "$target "; - $i++; + foreach my $targets ($self->{pbot}->{interpreter}->unquoted_args($stuff->{arglist})) { + foreach my $target (split /,/, $targets) { + $mode .= $mode_char; + $list .= "$target "; + $i++; - if ($i >= $max_modes) { + if ($i >= $max_modes) { + my $args = "$channel $mode $list"; + $stuff->{arglist} = $self->{pbot}->{interpreter}->make_args($args); + $result = $self->mode($channel, $nick, $stuff->{user}, $stuff->{host}, $args, $stuff); + $mode = $flag; + $list = ''; + $i = 0; + last if $result ne '' and $result ne 'Done.'; + } + } + } + + if ($i) { my $args = "$channel $mode $list"; $stuff->{arglist} = $self->{pbot}->{interpreter}->make_args($args); $result = $self->mode($channel, $nick, $stuff->{user}, $stuff->{host}, $args, $stuff); - $mode = $flag; - $list = ''; - $i = 0; - last if $result ne '' and $result ne 'Done.'; - } } - } - if ($i) { - my $args = "$channel $mode $list"; - $stuff->{arglist} = $self->{pbot}->{interpreter}->make_args($args); - $result = $self->mode($channel, $nick, $stuff->{user}, $stuff->{host}, $args, $stuff); - } - - return $result; + return $result; } sub op_user { - my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; - return $self->generic_mode_user('+o', 'op', $from, $nick, $stuff); + my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; + return $self->generic_mode_user('+o', 'op', $from, $nick, $stuff); } sub deop_user { - my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; - return $self->generic_mode_user('-o', 'deop', $from, $nick, $stuff); + my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; + return $self->generic_mode_user('-o', 'deop', $from, $nick, $stuff); } sub voice_user { - my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; - return $self->generic_mode_user('+v', 'voice', $from, $nick, $stuff); + my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; + return $self->generic_mode_user('+v', 'voice', $from, $nick, $stuff); } sub devoice_user { - my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; - return $self->generic_mode_user('-v', 'devoice', $from, $nick, $stuff); + my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; + return $self->generic_mode_user('-v', 'devoice', $from, $nick, $stuff); } sub mode { - my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; + my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; - if (not length $arguments) { - return "Usage: mode [channel] "; - } + if (not length $arguments) { return "Usage: mode [channel] "; } - # add current channel as default channel - if ($stuff->{arglist}[0] !~ m/^#/) { - if ($from =~ m/^#/) { - $self->{pbot}->{interpreter}->unshift_arg($stuff->{arglist}, $from); - } else { - return "Usage from private message: mode "; - } - } - - my ($channel, $modes, $args) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3); - my @targets = split /\s+/, $args if defined $args; - my $modifier; - my $i = 0; - my $arg = 0; - - my ($new_modes, $new_targets) = ("", ""); - my $max_modes = $self->{pbot}->{ircd}->{MODES} // 1; - - my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); - - while ($modes =~ m/(.)/g) { - my $mode = $1; - - if ($mode eq '-' or $mode eq '+') { - $modifier = $mode; - $new_modes .= $mode; - next; + # add current channel as default channel + if ($stuff->{arglist}[0] !~ m/^#/) { + if ($from =~ m/^#/) { $self->{pbot}->{interpreter}->unshift_arg($stuff->{arglist}, $from); } + else { return "Usage from private message: mode "; } } - if (not $self->{pbot}->{capabilities}->userhas($u, "can-mode-$mode")) { - return "/msg $nick Your user account does not have the can-mode-$mode capability required to set this mode."; - } + my ($channel, $modes, $args) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3); + my @targets = split /\s+/, $args if defined $args; + my $modifier; + my $i = 0; + my $arg = 0; - my $target = $targets[$arg++] // ""; + my ($new_modes, $new_targets) = ("", ""); + my $max_modes = $self->{pbot}->{ircd}->{MODES} // 1; - if (($mode eq 'v' or $mode eq 'o') and $target =~ m/\*/) { - # wildcard used; find all matching nicks; test against whitelist, etc - my $q_target = lc quotemeta $target; - $q_target =~ s/\\\*/.*/g; - $channel = lc $channel; + my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); - if (not exists $self->{pbot}->{nicklist}->{nicklist}->{$channel}) { - return "I have no nicklist for channel $channel; cannot use wildcard."; - } + while ($modes =~ m/(.)/g) { + my $mode = $1; - my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); - if ($mode eq 'v') { - if (not $self->{pbot}->{capabilities}->userhas($u, 'can-voice-wildcard')) { - return "/msg $nick Using wildcards with `mode v` requires the can-voice-wildcard capability, which your user account does not have."; + if ($mode eq '-' or $mode eq '+') { + $modifier = $mode; + $new_modes .= $mode; + next; } - } else { - if (not $self->{pbot}->{capabilities}->userhas($u, 'can-op-wildcard')) { - return "/msg $nick Using wildcards with `mode o` requires the can-op-wildcard capability, which your user account does not have."; + + if (not $self->{pbot}->{capabilities}->userhas($u, "can-mode-$mode")) { + return "/msg $nick Your user account does not have the can-mode-$mode capability required to set this mode."; } - } - foreach my $n (keys %{$self->{pbot}->{nicklist}->{nicklist}->{$channel}}) { - if ($n =~ m/^$q_target$/) { - my $nick_data = $self->{pbot}->{nicklist}->{nicklist}->{$channel}->{$n}; + my $target = $targets[$arg++] // ""; - if ($modifier eq '-') { - # removing mode -- check against whitelist, etc - next if $nick_data->{nick} eq $self->{pbot}->{registry}->get_value('irc', 'botnick'); - my $u = $self->{pbot}->{users}->loggedin($channel, $nick_data->{hostmask}); - next if $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted'); - } + if (($mode eq 'v' or $mode eq 'o') and $target =~ m/\*/) { - # skip nick if already has mode set/unset - if ($modifier eq '+') { - next if exists $nick_data->{"+$mode"}; - } else { - next unless exists $nick_data->{"+$mode"}; - } + # wildcard used; find all matching nicks; test against whitelist, etc + my $q_target = lc quotemeta $target; + $q_target =~ s/\\\*/.*/g; + $channel = lc $channel; - $new_modes = $modifier if not length $new_modes; - $new_modes .= $mode; - $new_targets .= "$self->{pbot}->{nicklist}->{nicklist}->{$channel}->{$n}->{nick} "; - $i++; + if (not exists $self->{pbot}->{nicklist}->{nicklist}->{$channel}) { return "I have no nicklist for channel $channel; cannot use wildcard."; } - if ($i == $max_modes) { - $self->{pbot}->{chanops}->add_op_command($channel, "mode $channel $new_modes $new_targets"); - $new_modes = ""; - $new_targets = ""; - $i = 0; - } + my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); + if ($mode eq 'v') { + if (not $self->{pbot}->{capabilities}->userhas($u, 'can-voice-wildcard')) { + return "/msg $nick Using wildcards with `mode v` requires the can-voice-wildcard capability, which your user account does not have."; + } + } else { + if (not $self->{pbot}->{capabilities}->userhas($u, 'can-op-wildcard')) { + return "/msg $nick Using wildcards with `mode o` requires the can-op-wildcard capability, which your user account does not have."; + } + } + + foreach my $n (keys %{$self->{pbot}->{nicklist}->{nicklist}->{$channel}}) { + if ($n =~ m/^$q_target$/) { + my $nick_data = $self->{pbot}->{nicklist}->{nicklist}->{$channel}->{$n}; + + if ($modifier eq '-') { + + # removing mode -- check against whitelist, etc + next if $nick_data->{nick} eq $self->{pbot}->{registry}->get_value('irc', 'botnick'); + my $u = $self->{pbot}->{users}->loggedin($channel, $nick_data->{hostmask}); + next if $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted'); + } + + # skip nick if already has mode set/unset + if ($modifier eq '+') { next if exists $nick_data->{"+$mode"}; } + else { next unless exists $nick_data->{"+$mode"}; } + + $new_modes = $modifier if not length $new_modes; + $new_modes .= $mode; + $new_targets .= "$self->{pbot}->{nicklist}->{nicklist}->{$channel}->{$n}->{nick} "; + $i++; + + if ($i == $max_modes) { + $self->{pbot}->{chanops}->add_op_command($channel, "mode $channel $new_modes $new_targets"); + $new_modes = ""; + $new_targets = ""; + $i = 0; + } + } + } + } else { + + # no wildcard used; explicit mode requested - no whitelist checking + $new_modes .= $mode; + $new_targets .= "$target " if length $target; + $i++; + + if ($i == $max_modes) { + $self->{pbot}->{chanops}->add_op_command($channel, "mode $channel $new_modes $new_targets"); + $new_modes = ""; + $new_targets = ""; + $i = 0; + } } - } - } else { - # no wildcard used; explicit mode requested - no whitelist checking - $new_modes .= $mode; - $new_targets .= "$target " if length $target; - $i++; - - if ($i == $max_modes) { - $self->{pbot}->{chanops}->add_op_command($channel, "mode $channel $new_modes $new_targets"); - $new_modes = ""; - $new_targets = ""; - $i = 0; - } } - } - if ($i) { - $self->{pbot}->{chanops}->add_op_command($channel, "mode $channel $new_modes $new_targets"); - } + if ($i) { $self->{pbot}->{chanops}->add_op_command($channel, "mode $channel $new_modes $new_targets"); } - $self->{pbot}->{chanops}->gain_ops($channel); + $self->{pbot}->{chanops}->gain_ops($channel); - if ($from !~ m/^#/) { - return "Done."; - } else { - return ""; - } + if ($from !~ m/^#/) { return "Done."; } + else { return ""; } } sub checkban { - my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; - my ($target, $channel) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); + my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; + my ($target, $channel) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); - return "Usage: checkban [channel]" if not defined $target; - $channel = $from if not defined $channel; + return "Usage: checkban [channel]" if not defined $target; + $channel = $from if not defined $channel; - return "Please specify a channel." if $channel !~ /^#/; - return $self->{pbot}->{chanops}->checkban($channel, $target); + return "Please specify a channel." if $channel !~ /^#/; + return $self->{pbot}->{chanops}->checkban($channel, $target); } sub checkmute { - my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; - my ($target, $channel) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); + my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; + my ($target, $channel) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); - return "Usage: checkmute [channel]" if not defined $target; - $channel = $from if not defined $channel; + return "Usage: checkmute [channel]" if not defined $target; + $channel = $from if not defined $channel; - return "Please specify a channel." if $channel !~ /^#/; - return $self->{pbot}->{chanops}->checkmute($channel, $target); + return "Please specify a channel." if $channel !~ /^#/; + return $self->{pbot}->{chanops}->checkmute($channel, $target); } sub ban_user { - my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; - my ($target, $channel, $length) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3); + my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; + my ($target, $channel, $length) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3); - $channel = '' if not defined $channel; - $length = '' if not defined $length; + $channel = '' if not defined $channel; + $length = '' if not defined $length; - if (not defined $from) { - $self->{pbot}->{logger}->log("Command missing ~from parameter!\n"); - return ""; - } - - if ($channel !~ m/^#/) { - $length = "$channel $length"; - $length = undef if $length eq ' '; - $channel = exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from; - } - - $channel = exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from if not defined $channel or not length $channel; - - if (not defined $target) { - return "Usage: ban [channel [timeout (default: 24 hours)]]"; - } - - my $no_length = 0; - if (not defined $length) { - $length = $self->{pbot}->{registry}->get_value($channel, 'default_ban_timeout', 0, $stuff) // - $self->{pbot}->{registry}->get_value('general', 'default_ban_timeout', 0, $stuff) // 60 * 60 * 24; # 24 hours - $no_length = 1; - } else { - my $error; - ($length, $error) = $self->{pbot}->{parsedate}->parsedate($length); - return $error if defined $error; - } - - $channel = lc $channel; - $target = lc $target; - - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - return "I don't think so." if $target =~ /^\Q$botnick\E!/i; - - my $result = ''; - my $sep = ''; - my @targets = split /,/, $target; - my $immediately = @targets > 1 ? 0 : 1; - my $duration; - foreach my $t (@targets) { - my $mask = lc $self->{pbot}->{chanops}->nick_to_banmask($t); - - if ($no_length && $self->{pbot}->{chanops}->{unban_timeout}->exists($channel, $mask)) { - my $timeout = $self->{pbot}->{chanops}->{unban_timeout}->get_data($channel, $mask, 'timeout'); - my $d = duration($timeout - gettimeofday); - $result .= "$sep$mask has $d remaining on their $channel ban"; - $sep = '; '; - } else { - $self->{pbot}->{chanops}->ban_user_timed("$nick!$user\@$host", undef, $mask, $channel, $length, $immediately); - $duration = $length > 0 ? duration $length : 'all eternity'; - if ($immediately) { - $result .= "$sep$mask banned in $channel for $duration"; - $sep = '; '; - } else { - $result .= "$sep$mask"; - $sep = ', '; - } + if (not defined $from) { + $self->{pbot}->{logger}->log("Command missing ~from parameter!\n"); + return ""; } - } - if (not $immediately) { - $result .= " banned in $channel for $duration"; - $self->{pbot}->{chanops}->check_ban_queue; - } + if ($channel !~ m/^#/) { + $length = "$channel $length"; + $length = undef if $length eq ' '; + $channel = exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from; + } - $result = "/msg $nick $result" if $result !~ m/remaining on their/; - return $result; + $channel = exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from if not defined $channel or not length $channel; + + if (not defined $target) { return "Usage: ban [channel [timeout (default: 24 hours)]]"; } + + my $no_length = 0; + if (not defined $length) { + $length = $self->{pbot}->{registry}->get_value($channel, 'default_ban_timeout', 0, $stuff) + // $self->{pbot}->{registry}->get_value('general', 'default_ban_timeout', 0, $stuff) // 60 * 60 * 24; # 24 hours + $no_length = 1; + } else { + my $error; + ($length, $error) = $self->{pbot}->{parsedate}->parsedate($length); + return $error if defined $error; + } + + $channel = lc $channel; + $target = lc $target; + + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + return "I don't think so." if $target =~ /^\Q$botnick\E!/i; + + my $result = ''; + my $sep = ''; + my @targets = split /,/, $target; + my $immediately = @targets > 1 ? 0 : 1; + my $duration; + + foreach my $t (@targets) { + my $mask = lc $self->{pbot}->{chanops}->nick_to_banmask($t); + + if ($no_length && $self->{pbot}->{chanops}->{unban_timeout}->exists($channel, $mask)) { + my $timeout = $self->{pbot}->{chanops}->{unban_timeout}->get_data($channel, $mask, 'timeout'); + my $d = duration($timeout - gettimeofday); + $result .= "$sep$mask has $d remaining on their $channel ban"; + $sep = '; '; + } else { + $self->{pbot}->{chanops}->ban_user_timed("$nick!$user\@$host", undef, $mask, $channel, $length, $immediately); + $duration = $length > 0 ? duration $length : 'all eternity'; + if ($immediately) { + $result .= "$sep$mask banned in $channel for $duration"; + $sep = '; '; + } else { + $result .= "$sep$mask"; + $sep = ', '; + } + } + } + + if (not $immediately) { + $result .= " banned in $channel for $duration"; + $self->{pbot}->{chanops}->check_ban_queue; + } + + $result = "/msg $nick $result" if $result !~ m/remaining on their/; + return $result; } sub unban_user { - my $self = shift; - my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; - if (not defined $from) { - $self->{pbot}->{logger}->log("Command missing ~from parameter!\n"); - return ""; - } - - my ($target, $channel, $immediately) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3); - - if (defined $target and defined $channel and $channel !~ /^#/) { - my $temp = $target; - $target = $channel; - $channel = $temp; - } - - if (not defined $target) { - return "Usage: unban [channel [false value to use unban queue]]"; - } - - $channel = exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from if not defined $channel; - $immediately = 1 if not defined $immediately; - - return "Usage for /msg: unban [false value to use unban queue]" if $channel !~ /^#/; - - my @targets = split /,/, $target; - $immediately = 0 if @targets > 1; - - foreach my $t (@targets) { - if ($t eq '*') { - my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); - if (not $self->{pbot}->{capabilities}->userhas($u, 'can-clear-bans')) { - return "/msg $nick Clearing the channel bans requires the can-clear-bans capability, which your user account does not have."; - } - $channel = lc $channel; - if (exists $self->{pbot}->{bantracker}->{banlist}->{$channel} && exists $self->{pbot}->{bantracker}->{banlist}->{$channel}->{'+b'}) { - $immediately = 0; - foreach my $banmask (keys %{ $self->{pbot}->{bantracker}->{banlist}->{$channel}->{'+b'} }) { - $self->{pbot}->{chanops}->unban_user($banmask, $channel, $immediately); - } - last; - } - } else { - $self->{pbot}->{chanops}->unban_user($t, $channel, $immediately); + if (not defined $from) { + $self->{pbot}->{logger}->log("Command missing ~from parameter!\n"); + return ""; } - } - $self->{pbot}->{chanops}->check_unban_queue if not $immediately; - return "/msg $nick $target has been unbanned from $channel."; + my ($target, $channel, $immediately) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3); + + if (defined $target and defined $channel and $channel !~ /^#/) { + my $temp = $target; + $target = $channel; + $channel = $temp; + } + + if (not defined $target) { return "Usage: unban [channel [false value to use unban queue]]"; } + + $channel = exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from if not defined $channel; + $immediately = 1 if not defined $immediately; + + return "Usage for /msg: unban [false value to use unban queue]" if $channel !~ /^#/; + + my @targets = split /,/, $target; + $immediately = 0 if @targets > 1; + + foreach my $t (@targets) { + if ($t eq '*') { + my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); + if (not $self->{pbot}->{capabilities}->userhas($u, 'can-clear-bans')) { + return "/msg $nick Clearing the channel bans requires the can-clear-bans capability, which your user account does not have."; + } + $channel = lc $channel; + if (exists $self->{pbot}->{bantracker}->{banlist}->{$channel} && exists $self->{pbot}->{bantracker}->{banlist}->{$channel}->{'+b'}) { + $immediately = 0; + foreach my $banmask (keys %{$self->{pbot}->{bantracker}->{banlist}->{$channel}->{'+b'}}) { $self->{pbot}->{chanops}->unban_user($banmask, $channel, $immediately); } + last; + } + } else { + $self->{pbot}->{chanops}->unban_user($t, $channel, $immediately); + } + } + + $self->{pbot}->{chanops}->check_unban_queue if not $immediately; + return "/msg $nick $target has been unbanned from $channel."; } sub mute_user { - my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; - my ($target, $channel, $length) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3); + my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; + my ($target, $channel, $length) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3); - if (not defined $from) { - $self->{pbot}->{logger}->log("Command missing ~from parameter!\n"); - return ""; - } - - if (not defined $channel and $from !~ m/^#/) { - return "Usage from private message: mute [timeout (default: 24 hours)]"; - } - - if ($channel !~ m/^#/) { - $length = "$channel $length"; - $length = undef if $length eq ' '; - $channel = exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from; - } - - $channel = exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from if not defined $channel; - - if ($channel !~ m/^#/) { - return "Please specify a channel."; - } - - if (not defined $target) { - return "Usage: mute [channel [timeout (default: 24 hours)]]"; - } - - my $no_length = 0; - if (not defined $length) { - $length = $self->{pbot}->{registry}->get_value($channel, 'default_mute_timeout', 0, $stuff) // - $self->{pbot}->{registry}->get_value('general', 'default_mute_timeout', 0, $stuff) // 60 * 60 * 24; # 24 hours - $no_length = 1; - } else { - my $error; - ($length, $error) = $self->{pbot}->{parsedate}->parsedate($length); - return $error if defined $error; - } - - $channel = lc $channel; - $target = lc $target; - - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - return "I don't think so." if $target =~ /^\Q$botnick\E!/i; - - my $result = ''; - my $sep = ''; - my @targets = split /,/, $target; - my $immediately = @targets > 1 ? 0 : 1; - my $duration; - foreach my $t (@targets) { - my $mask = lc $self->{pbot}->{chanops}->nick_to_banmask($t); - - if ($no_length && $self->{pbot}->{chanops}->{unmute_timeout}->exists($channel, $mask)) { - my $timeout = $self->{pbot}->{chanops}->{unmute_timeout}->get_data($channel, $mask, 'timeout'); - my $d = duration($timeout - gettimeofday); - $result .= "$sep$mask has $d remaining on their $channel mute"; - $sep = '; '; - } else { - $self->{pbot}->{chanops}->mute_user_timed("$nick!$user\@$host", undef, $t, $channel, $length, $immediately); - $duration = $length > 0 ? duration $length : 'all eternity'; - if ($immediately) { - $result .= "$sep$mask muted in $channel for $duration"; - $sep = '; '; - } else { - $result .= "$sep$mask"; - $sep = ', '; - } + if (not defined $from) { + $self->{pbot}->{logger}->log("Command missing ~from parameter!\n"); + return ""; } - } - if (not $immediately) { - $result .= " muted in $channel for $duration"; - $self->{pbot}->{chanops}->check_ban_queue; - } + if (not defined $channel and $from !~ m/^#/) { return "Usage from private message: mute [timeout (default: 24 hours)]"; } - $result = "/msg $nick $result" if $result !~ m/remaining on their/; - return $result; + if ($channel !~ m/^#/) { + $length = "$channel $length"; + $length = undef if $length eq ' '; + $channel = exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from; + } + + $channel = exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from if not defined $channel; + + if ($channel !~ m/^#/) { return "Please specify a channel."; } + + if (not defined $target) { return "Usage: mute [channel [timeout (default: 24 hours)]]"; } + + my $no_length = 0; + if (not defined $length) { + $length = $self->{pbot}->{registry}->get_value($channel, 'default_mute_timeout', 0, $stuff) + // $self->{pbot}->{registry}->get_value('general', 'default_mute_timeout', 0, $stuff) // 60 * 60 * 24; # 24 hours + $no_length = 1; + } else { + my $error; + ($length, $error) = $self->{pbot}->{parsedate}->parsedate($length); + return $error if defined $error; + } + + $channel = lc $channel; + $target = lc $target; + + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + return "I don't think so." if $target =~ /^\Q$botnick\E!/i; + + my $result = ''; + my $sep = ''; + my @targets = split /,/, $target; + my $immediately = @targets > 1 ? 0 : 1; + my $duration; + + foreach my $t (@targets) { + my $mask = lc $self->{pbot}->{chanops}->nick_to_banmask($t); + + if ($no_length && $self->{pbot}->{chanops}->{unmute_timeout}->exists($channel, $mask)) { + my $timeout = $self->{pbot}->{chanops}->{unmute_timeout}->get_data($channel, $mask, 'timeout'); + my $d = duration($timeout - gettimeofday); + $result .= "$sep$mask has $d remaining on their $channel mute"; + $sep = '; '; + } else { + $self->{pbot}->{chanops}->mute_user_timed("$nick!$user\@$host", undef, $t, $channel, $length, $immediately); + $duration = $length > 0 ? duration $length : 'all eternity'; + if ($immediately) { + $result .= "$sep$mask muted in $channel for $duration"; + $sep = '; '; + } else { + $result .= "$sep$mask"; + $sep = ', '; + } + } + } + + if (not $immediately) { + $result .= " muted in $channel for $duration"; + $self->{pbot}->{chanops}->check_ban_queue; + } + + $result = "/msg $nick $result" if $result !~ m/remaining on their/; + return $result; } sub unmute_user { - my $self = shift; - my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; - if (not defined $from) { - $self->{pbot}->{logger}->log("Command missing ~from parameter!\n"); - return ""; - } - - my ($target, $channel, $immediately) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3); - - if (defined $target and defined $channel and $channel !~ /^#/) { - my $temp = $target; - $target = $channel; - $channel = $temp; - } - - if (not defined $target) { - return "Usage: unmute [channel [false value to use unban queue]]"; - } - - $channel = exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from if not defined $channel; - $immediately = 1 if not defined $immediately; - - return "Usage for /msg: unmute [false value to use unban queue]" if $channel !~ /^#/; - - my @targets = split /,/, $target; - $immediately = 0 if @targets > 1; - - foreach my $t (@targets) { - if ($t eq '*') { - my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); - if (not $self->{pbot}->{capabilities}->userhas($u, 'can-clear-mutes')) { - return "/msg $nick Clearing the channel mutes requires the can-clear-mutes capability, which your user account does not have."; - } - $channel = lc $channel; - if (exists $self->{pbot}->{bantracker}->{banlist}->{$channel} && exists $self->{pbot}->{bantracker}->{banlist}->{$channel}->{'+q'}) { - $immediately = 0; - foreach my $banmask (keys %{ $self->{pbot}->{bantracker}->{banlist}->{$channel}->{'+q'} }) { - $self->{pbot}->{chanops}->unmute_user($banmask, $channel, $immediately); - } - last; - } - } else { - $self->{pbot}->{chanops}->unmute_user($t, $channel, $immediately); + if (not defined $from) { + $self->{pbot}->{logger}->log("Command missing ~from parameter!\n"); + return ""; } - } - $self->{pbot}->{chanops}->check_unban_queue if not $immediately; - return "/msg $nick $target has been unmuted in $channel."; + my ($target, $channel, $immediately) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3); + + if (defined $target and defined $channel and $channel !~ /^#/) { + my $temp = $target; + $target = $channel; + $channel = $temp; + } + + if (not defined $target) { return "Usage: unmute [channel [false value to use unban queue]]"; } + + $channel = exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from if not defined $channel; + $immediately = 1 if not defined $immediately; + + return "Usage for /msg: unmute [false value to use unban queue]" if $channel !~ /^#/; + + my @targets = split /,/, $target; + $immediately = 0 if @targets > 1; + + foreach my $t (@targets) { + if ($t eq '*') { + my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); + if (not $self->{pbot}->{capabilities}->userhas($u, 'can-clear-mutes')) { + return "/msg $nick Clearing the channel mutes requires the can-clear-mutes capability, which your user account does not have."; + } + $channel = lc $channel; + if (exists $self->{pbot}->{bantracker}->{banlist}->{$channel} && exists $self->{pbot}->{bantracker}->{banlist}->{$channel}->{'+q'}) { + $immediately = 0; + foreach my $banmask (keys %{$self->{pbot}->{bantracker}->{banlist}->{$channel}->{'+q'}}) { $self->{pbot}->{chanops}->unmute_user($banmask, $channel, $immediately); } + last; + } + } else { + $self->{pbot}->{chanops}->unmute_user($t, $channel, $immediately); + } + } + + $self->{pbot}->{chanops}->check_unban_queue if not $immediately; + return "/msg $nick $target has been unmuted in $channel."; } sub kick_user { - my $self = shift; - my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; - if (not defined $from) { - $self->{pbot}->{logger}->log("Command missing ~from parameter!\n"); - return ""; - } - - my ($channel, $victim, $reason); - - if (not $from =~ /^#/) { - # used in private message - if (not $arguments =~ s/^(^#\S+) (\S+)\s*//) { - return "Usage from private message: kick [reason]"; + if (not defined $from) { + $self->{pbot}->{logger}->log("Command missing ~from parameter!\n"); + return ""; } - ($channel, $victim) = ($1, $2); - } else { - # used in channel - if ($arguments =~ s/^(#\S+)\s+(\S+)\s*//) { - ($channel, $victim) = ($1, $2); - } elsif ($arguments =~ s/^(\S+)\s*//) { - ($victim, $channel) = ($1, exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from); + + my ($channel, $victim, $reason); + + if (not $from =~ /^#/) { + + # used in private message + if (not $arguments =~ s/^(^#\S+) (\S+)\s*//) { return "Usage from private message: kick [reason]"; } + ($channel, $victim) = ($1, $2); } else { - return "Usage: kick [channel] [reason]"; + + # used in channel + if ($arguments =~ s/^(#\S+)\s+(\S+)\s*//) { ($channel, $victim) = ($1, $2); } + elsif ($arguments =~ s/^(\S+)\s*//) { ($victim, $channel) = ($1, exists $stuff->{admin_channel_override} ? $stuff->{admin_channel_override} : $from); } + else { return "Usage: kick [channel] [reason]"; } } - } - $reason = $arguments; + $reason = $arguments; - # If the user is too stupid to remember the order of the arguments, - # we can help them out by seeing if they put the channel in the reason. - if ($reason =~ s/^(#\S+)\s*//) { - $channel = $1; - } + # If the user is too stupid to remember the order of the arguments, + # we can help them out by seeing if they put the channel in the reason. + if ($reason =~ s/^(#\S+)\s*//) { $channel = $1; } - my @insults; - if (not length $reason) { - if (open my $fh, '<', $self->{pbot}->{registry}->get_value('general', 'module_dir') . '/insults.txt') { - @insults = <$fh>; - close $fh; - $reason = $insults[rand @insults]; - $reason =~ s/\s+$//; - } else { - $reason = 'Bye!'; - } - } - - my @nicks = split /,/, $victim; - foreach my $n (@nicks) { - if ($n =~ m/\*/) { - # wildcard used; find all matching nicks; test against whitelist, etc - my $q_target = lc quotemeta $n; - $q_target =~ s/\\\*/.*/g; - $channel = lc $channel; - - if (not exists $self->{pbot}->{nicklist}->{nicklist}->{$channel}) { - return "I have no nicklist for channel $channel; cannot use wildcard."; - } - - my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); - if (not $self->{pbot}->{capabilities}->userhas($u, 'can-kick-wildcard')) { - return "/msg $nick Using wildcards with `kick` requires the can-kick-wildcard capability, which your user account does not have."; - } - - foreach my $nl (keys %{$self->{pbot}->{nicklist}->{nicklist}->{$channel}}) { - if ($nl =~ m/^$q_target$/) { - my $nick_data = $self->{pbot}->{nicklist}->{nicklist}->{$channel}->{$nl}; - - next if $nick_data->{nick} eq $self->{pbot}->{registry}->get_value('irc', 'botnick'); - my $u = $self->{pbot}->{users}->loggedin($channel, $nick_data->{hostmask}); - next if $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted'); - - $self->{pbot}->{chanops}->add_op_command($channel, "kick $channel $nl $reason"); + my @insults; + if (not length $reason) { + if (open my $fh, '<', $self->{pbot}->{registry}->get_value('general', 'module_dir') . '/insults.txt') { + @insults = <$fh>; + close $fh; + $reason = $insults[rand @insults]; + $reason =~ s/\s+$//; + } else { + $reason = 'Bye!'; } - } - } else { - # no wildcard used, explicit kick - $self->{pbot}->{chanops}->add_op_command($channel, "kick $channel $n $reason"); } - # randomize next kick reason - if (@insults) { - $reason = $insults[rand @insults]; - $reason =~ s/\s+$//; - } - } + my @nicks = split /,/, $victim; + foreach my $n (@nicks) { + if ($n =~ m/\*/) { - $self->{pbot}->{chanops}->gain_ops($channel); - return ""; + # wildcard used; find all matching nicks; test against whitelist, etc + my $q_target = lc quotemeta $n; + $q_target =~ s/\\\*/.*/g; + $channel = lc $channel; + + if (not exists $self->{pbot}->{nicklist}->{nicklist}->{$channel}) { return "I have no nicklist for channel $channel; cannot use wildcard."; } + + my $u = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); + if (not $self->{pbot}->{capabilities}->userhas($u, 'can-kick-wildcard')) { + return "/msg $nick Using wildcards with `kick` requires the can-kick-wildcard capability, which your user account does not have."; + } + + foreach my $nl (keys %{$self->{pbot}->{nicklist}->{nicklist}->{$channel}}) { + if ($nl =~ m/^$q_target$/) { + my $nick_data = $self->{pbot}->{nicklist}->{nicklist}->{$channel}->{$nl}; + + next if $nick_data->{nick} eq $self->{pbot}->{registry}->get_value('irc', 'botnick'); + my $u = $self->{pbot}->{users}->loggedin($channel, $nick_data->{hostmask}); + next if $self->{pbot}->{capabilities}->userhas($u, 'is-whitelisted'); + + $self->{pbot}->{chanops}->add_op_command($channel, "kick $channel $nl $reason"); + } + } + } else { + + # no wildcard used, explicit kick + $self->{pbot}->{chanops}->add_op_command($channel, "kick $channel $n $reason"); + } + + # randomize next kick reason + if (@insults) { + $reason = $insults[rand @insults]; + $reason =~ s/\s+$//; + } + } + + $self->{pbot}->{chanops}->gain_ops($channel); + return ""; } 1; diff --git a/PBot/ChanOps.pm b/PBot/ChanOps.pm index 9cc5a9c9..b0ccdacd 100644 --- a/PBot/ChanOps.pm +++ b/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; diff --git a/PBot/Channels.pm b/PBot/Channels.pm index deb5d2ea..63074461 100644 --- a/PBot/Channels.pm +++ b/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 [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 [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 " 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 " 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 " if not defined $arguments or not length $arguments; + my ($self, $from, $nick, $user, $host, $arguments) = @_; + return "Usage: chanadd " 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 " if not defined $arguments or not length $arguments; + my ($self, $from, $nick, $user, $host, $arguments) = @_; + return "Usage: chanrem " 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; diff --git a/PBot/Class.pm b/PBot/Class.pm index 625bcc7d..790acd9d 100644 --- a/PBot/Class.pm +++ b/PBot/Class.pm @@ -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; diff --git a/PBot/Commands.pm b/PBot/Commands.pm index 85833cb6..1b9786e1 100644 --- a/PBot/Commands.pm +++ b/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 [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 [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 " 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 " 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 . For help about a specific command or factoid, use `help [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 . For help about a specific command or factoid, use `help [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 ` 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 ` 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 "; - return $usage if not $arguments; + my $usage = "Usage: in "; + 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; diff --git a/PBot/DualIndexHashObject.pm b/PBot/DualIndexHashObject.pm index 1c79eb6f..8b868f7d 100644 --- a/PBot/DualIndexHashObject.pm +++ b/PBot/DualIndexHashObject.pm @@ -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 $/; - ; - }; - - $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 $/; + ; + }; + + $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; diff --git a/PBot/EventDispatcher.pm b/PBot/EventDispatcher.pm index 3c87e873..7698ef2e 100644 --- a/PBot/EventDispatcher.pm +++ b/PBot/EventDispatcher.pm @@ -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; diff --git a/PBot/FactoidCommands.pm b/PBot/FactoidCommands.pm index a73c24b4..0799070d 100644 --- a/PBot/FactoidCommands.pm +++ b/PBot/FactoidCommands.pm @@ -8,6 +8,7 @@ # file, You can obtain one at http://mozilla.org/MPL/2.0/. package PBot::FactoidCommands; + use parent 'PBot::Class'; use warnings; use strict; @@ -24,1599 +25,1543 @@ use JSON; use PBot::Utils::SafeFilename; our %factoid_metadata_capabilities = ( - created_on => 'botowner', - enabled => 'chanop', - last_referenced_in => 'botowner', - last_referenced_on => 'botowner', - modulelauncher_subpattern => 'botowner', - owner => 'botowner', - rate_limit => 'chanop', - ref_count => 'botowner', - ref_user => 'botowner', - type => 'botowner', - edited_by => 'botowner', - edited_on => 'botowner', - locked => 'chanop', - add_nick => 'chanop', - nooverride => 'chanop', - 'cap-override' => 'botowner', - 'persist-key' => 'admin', - # all others are allowed to be factset by anybody + created_on => 'botowner', + enabled => 'chanop', + last_referenced_in => 'botowner', + last_referenced_on => 'botowner', + modulelauncher_subpattern => 'botowner', + owner => 'botowner', + rate_limit => 'chanop', + ref_count => 'botowner', + ref_user => 'botowner', + type => 'botowner', + edited_by => 'botowner', + edited_on => 'botowner', + locked => 'chanop', + add_nick => 'chanop', + nooverride => 'chanop', + 'cap-override' => 'botowner', + 'persist-key' => 'admin', + + # all others are allowed to be factset by anybody ); sub initialize { - my ($self, %conf) = @_; - $self->{pbot}->{registry}->add_default('text', 'general', 'module_repo', $conf{module_repo} // 'https://github.com/pragma-/pbot/blob/master/modules/'); + my ($self, %conf) = @_; + $self->{pbot}->{registry}->add_default('text', 'general', 'module_repo', $conf{module_repo} // 'https://github.com/pragma-/pbot/blob/master/modules/'); - $self->{pbot}->{commands}->register(sub { $self->factadd(@_) }, "learn", 0); - $self->{pbot}->{commands}->register(sub { $self->factadd(@_) }, "factadd", 0); - $self->{pbot}->{commands}->register(sub { $self->factrem(@_) }, "forget", 0); - $self->{pbot}->{commands}->register(sub { $self->factrem(@_) }, "factrem", 0); - $self->{pbot}->{commands}->register(sub { $self->factshow(@_) }, "factshow", 0); - $self->{pbot}->{commands}->register(sub { $self->factinfo(@_) }, "factinfo", 0); - $self->{pbot}->{commands}->register(sub { $self->factlog(@_) }, "factlog", 0); - $self->{pbot}->{commands}->register(sub { $self->factundo(@_) }, "factundo", 0); - $self->{pbot}->{commands}->register(sub { $self->factredo(@_) }, "factredo", 0); - $self->{pbot}->{commands}->register(sub { $self->factset(@_) }, "factset", 0); - $self->{pbot}->{commands}->register(sub { $self->factunset(@_) }, "factunset", 0); - $self->{pbot}->{commands}->register(sub { $self->factchange(@_) }, "factchange", 0); - $self->{pbot}->{commands}->register(sub { $self->factalias(@_) }, "factalias", 0); - $self->{pbot}->{commands}->register(sub { $self->factmove(@_) }, "factmove", 0); - $self->{pbot}->{commands}->register(sub { $self->call_factoid(@_) }, "fact", 0); - $self->{pbot}->{commands}->register(sub { $self->factfind(@_) }, "factfind", 0); - $self->{pbot}->{commands}->register(sub { $self->top20(@_) }, "top20", 0); - $self->{pbot}->{commands}->register(sub { $self->histogram(@_) }, "histogram", 0); - $self->{pbot}->{commands}->register(sub { $self->count(@_) }, "count", 0); + $self->{pbot}->{commands}->register(sub { $self->factadd(@_) }, "learn", 0); + $self->{pbot}->{commands}->register(sub { $self->factadd(@_) }, "factadd", 0); + $self->{pbot}->{commands}->register(sub { $self->factrem(@_) }, "forget", 0); + $self->{pbot}->{commands}->register(sub { $self->factrem(@_) }, "factrem", 0); + $self->{pbot}->{commands}->register(sub { $self->factshow(@_) }, "factshow", 0); + $self->{pbot}->{commands}->register(sub { $self->factinfo(@_) }, "factinfo", 0); + $self->{pbot}->{commands}->register(sub { $self->factlog(@_) }, "factlog", 0); + $self->{pbot}->{commands}->register(sub { $self->factundo(@_) }, "factundo", 0); + $self->{pbot}->{commands}->register(sub { $self->factredo(@_) }, "factredo", 0); + $self->{pbot}->{commands}->register(sub { $self->factset(@_) }, "factset", 0); + $self->{pbot}->{commands}->register(sub { $self->factunset(@_) }, "factunset", 0); + $self->{pbot}->{commands}->register(sub { $self->factchange(@_) }, "factchange", 0); + $self->{pbot}->{commands}->register(sub { $self->factalias(@_) }, "factalias", 0); + $self->{pbot}->{commands}->register(sub { $self->factmove(@_) }, "factmove", 0); + $self->{pbot}->{commands}->register(sub { $self->call_factoid(@_) }, "fact", 0); + $self->{pbot}->{commands}->register(sub { $self->factfind(@_) }, "factfind", 0); + $self->{pbot}->{commands}->register(sub { $self->top20(@_) }, "top20", 0); + $self->{pbot}->{commands}->register(sub { $self->histogram(@_) }, "histogram", 0); + $self->{pbot}->{commands}->register(sub { $self->count(@_) }, "count", 0); - # the following commands have not yet been updated to use the new factoid structure - # DO NOT USE!! Factoid corruption may occur. - $self->{pbot}->{commands}->register(sub { $self->add_regex(@_) }, "regex", 1); + # the following commands have not yet been updated to use the new factoid structure + # DO NOT USE!! Factoid corruption may occur. + $self->{pbot}->{commands}->register(sub { $self->add_regex(@_) }, "regex", 1); } sub call_factoid { - my $self = shift; - my ($from, $nick, $user, $host, $arguments, $stuff) = @_; - my ($chan, $keyword, $args) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3, 0, 1); + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my ($chan, $keyword, $args) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3, 0, 1); - if (not defined $chan or not defined $keyword) { - return "Usage: fact [arguments]"; - } + if (not defined $chan or not defined $keyword) { return "Usage: fact [arguments]"; } - my ($channel, $trigger) = $self->{pbot}->{factoids}->find_factoid($chan, $keyword, arguments => $args, exact_channel => 1, exact_trigger => 1); + my ($channel, $trigger) = $self->{pbot}->{factoids}->find_factoid($chan, $keyword, arguments => $args, exact_channel => 1, exact_trigger => 1); - if (not defined $trigger) { - return "No such factoid $keyword exists for $chan"; - } + if (not defined $trigger) { return "No such factoid $keyword exists for $chan"; } - $stuff->{keyword} = $trigger; - $stuff->{trigger} = $trigger; - $stuff->{ref_from} = $channel; - $stuff->{arguments} = $args; - $stuff->{root_keyword} = $trigger; + $stuff->{keyword} = $trigger; + $stuff->{trigger} = $trigger; + $stuff->{ref_from} = $channel; + $stuff->{arguments} = $args; + $stuff->{root_keyword} = $trigger; - return $self->{pbot}->{factoids}->interpreter($stuff); + return $self->{pbot}->{factoids}->interpreter($stuff); } sub log_factoid { - my $self = shift; - my ($channel, $trigger, $hostmask, $msg, $dont_save_undo) = @_; + my $self = shift; + my ($channel, $trigger, $hostmask, $msg, $dont_save_undo) = @_; - $channel = lc $channel; - $trigger = lc $trigger; + $channel = lc $channel; + $trigger = lc $trigger; - my $channel_path = $channel; - $channel_path = 'global' if $channel_path eq '.*'; + my $channel_path = $channel; + $channel_path = 'global' if $channel_path eq '.*'; - my $channel_path_safe = safe_filename $channel_path; - my $trigger_safe = safe_filename $trigger; + my $channel_path_safe = safe_filename $channel_path; + my $trigger_safe = safe_filename $trigger; - my $path = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/factlog'; - open my $fh, ">> $path/$trigger_safe.$channel_path_safe" or do { - $self->{pbot}->{logger}->log("Failed to open factlog for $channel/$trigger: $!\n"); - return; - }; - - my $now = gettimeofday; - my $h = {ts => $now, hm => $hostmask, msg => $msg}; - my $json = encode_json $h; - print $fh "$json\n"; - close $fh; - - return if $dont_save_undo; - - my $undos = eval { retrieve("$path/$trigger_safe.$channel_path_safe.undo"); }; - - if (not $undos) { - $undos = { - idx => -1, - list => [] + my $path = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/factlog'; + open my $fh, ">> $path/$trigger_safe.$channel_path_safe" or do { + $self->{pbot}->{logger}->log("Failed to open factlog for $channel/$trigger: $!\n"); + return; }; - } - my $max_undos = $self->{pbot}->{registry}->get_value('factoids', 'max_undos') // 20; - if (@{$undos->{list}} > $max_undos) { - shift @{$undos->{list}}; - $undos->{idx}--; - } + my $now = gettimeofday; + my $h = {ts => $now, hm => $hostmask, msg => $msg}; + my $json = encode_json $h; + print $fh "$json\n"; + close $fh; - if ($undos->{idx} > -1 and @{$undos->{list}} > $undos->{idx} + 1) { - splice @{$undos->{list}}, $undos->{idx} + 1; - } + return if $dont_save_undo; - push @{$undos->{list}}, $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger); - $undos->{idx}++; + my $undos = eval { retrieve("$path/$trigger_safe.$channel_path_safe.undo"); }; - eval { store $undos, "$path/$trigger_safe.$channel_path_safe.undo"; }; - $self->{pbot}->{logger}->log("Error storing undo: $@\n") if $@; + if (not $undos) { + $undos = { + idx => -1, + list => [] + }; + } + + my $max_undos = $self->{pbot}->{registry}->get_value('factoids', 'max_undos') // 20; + if (@{$undos->{list}} > $max_undos) { + shift @{$undos->{list}}; + $undos->{idx}--; + } + + if ($undos->{idx} > -1 and @{$undos->{list}} > $undos->{idx} + 1) { splice @{$undos->{list}}, $undos->{idx} + 1; } + + push @{$undos->{list}}, $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger); + $undos->{idx}++; + + eval { store $undos, "$path/$trigger_safe.$channel_path_safe.undo"; }; + $self->{pbot}->{logger}->log("Error storing undo: $@\n") if $@; } sub find_factoid_with_optional_channel { - my ($self, $from, $arguments, $command, %opts) = @_; + my ($self, $from, $arguments, $command, %opts) = @_; - my %default_opts = ( - usage => undef, - explicit => 0, - exact_channel => 0 - ); + my %default_opts = ( + usage => undef, + explicit => 0, + exact_channel => 0 + ); - %opts = (%default_opts, %opts); - my $arglist = $self->{pbot}->{interpreter}->make_args($arguments); - my ($from_chan, $from_trigger, $remaining_args) = $self->{pbot}->{interpreter}->split_args($arglist, 3, 0, 1); + %opts = (%default_opts, %opts); + my $arglist = $self->{pbot}->{interpreter}->make_args($arguments); + my ($from_chan, $from_trigger, $remaining_args) = $self->{pbot}->{interpreter}->split_args($arglist, 3, 0, 1); - if (not defined $from_chan or (not defined $from_chan and not defined $from_trigger)) { - return "Usage: $command [channel] " if not $opts{usage}; - return $opts{usage}; - } - - my $needs_disambig; - if (not defined $from_trigger) { - # cmd arg1, so insert $from as channel - $from_trigger = $from_chan; - $from_chan = $from; - $remaining_args = ""; - #$needs_disambig = 1; - } else { - # cmd arg1 arg2 [...?] - if ($from_chan !~ /^#/ and lc $from_chan ne 'global' and $from_chan ne '.*') { - # not a channel or global, so must be a keyword - my $keyword = $from_chan; - $from_chan = $from; - $from_trigger = $keyword; - (undef, $remaining_args) = $self->{pbot}->{interpreter}->split_args($arglist, 2, 0, 1); - } - } - - $from_chan = '.*' if $from_chan !~ /^#/; - $from_chan = lc $from_chan; - - my ($channel, $trigger); - - if ($opts{exact_channel} == 1) { - ($channel, $trigger) = $self->{pbot}->{factoids}->find_factoid($from_chan, $from_trigger, exact_channel => 1, exact_trigger => 1); - - if (not defined $channel) { - $from_chan = 'the global channel' if $from_chan eq '.*'; - return "/say $from_trigger not found in $from_chan."; - } - } else { - my @factoids = $self->{pbot}->{factoids}->find_factoid($from_chan, $from_trigger, exact_trigger => 1); - - if (not @factoids or not $factoids[0]) { - if ($needs_disambig) { - return "/say $from_trigger not found"; - } else { - $from_chan = 'global channel' if $from_chan eq '.*'; - return "/say $from_trigger not found in $from_chan"; - } + if (not defined $from_chan or (not defined $from_chan and not defined $from_trigger)) { + return "Usage: $command [channel] " if not $opts{usage}; + return $opts{usage}; } - if (@factoids > 1) { - if ($needs_disambig or not grep { $_->[0] eq $from_chan } @factoids) { - unless ($opts{explicit}) { - foreach my $factoid (@factoids) { - if ($factoid->[0] eq '.*') { - ($channel, $trigger) = ($factoid->[0], $factoid->[1]); - } - } - } - if (not defined $channel) { - return "/say $from_trigger found in multiple channels: " . (join ', ', sort map { $_->[0] eq '.*' ? 'global' : $_->[0] } @factoids) . "; use `$command $from_trigger` to disambiguate."; - } - } else { - foreach my $factoid (@factoids) { - if ($factoid->[0] eq $from_chan) { - ($channel, $trigger) = ($factoid->[0], $factoid->[1]); - last; - } - } - } + my $needs_disambig; + if (not defined $from_trigger) { + + # cmd arg1, so insert $from as channel + $from_trigger = $from_chan; + $from_chan = $from; + $remaining_args = ""; + + #$needs_disambig = 1; } else { - ($channel, $trigger) = ($factoids[0]->[0], $factoids[0]->[1]); + + # cmd arg1 arg2 [...?] + if ($from_chan !~ /^#/ and lc $from_chan ne 'global' and $from_chan ne '.*') { + + # not a channel or global, so must be a keyword + my $keyword = $from_chan; + $from_chan = $from; + $from_trigger = $keyword; + (undef, $remaining_args) = $self->{pbot}->{interpreter}->split_args($arglist, 2, 0, 1); + } } - } - $channel = '.*' if $channel eq 'global'; - $from_chan = '.*' if $channel eq 'global'; + $from_chan = '.*' if $from_chan !~ /^#/; + $from_chan = lc $from_chan; - if ($opts{explicit} and $channel =~ /^#/ and $from_chan =~ /^#/ and $channel ne $from_chan) { - 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' if $channel_name eq '.*'; - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - return "/say $trigger_name belongs to $channel_name, not $from_chan. Please switch to or explicitly specify $channel_name."; - } - return ($channel, $trigger, $remaining_args); + my ($channel, $trigger); + + if ($opts{exact_channel} == 1) { + ($channel, $trigger) = $self->{pbot}->{factoids}->find_factoid($from_chan, $from_trigger, exact_channel => 1, exact_trigger => 1); + + if (not defined $channel) { + $from_chan = 'the global channel' if $from_chan eq '.*'; + return "/say $from_trigger not found in $from_chan."; + } + } else { + my @factoids = $self->{pbot}->{factoids}->find_factoid($from_chan, $from_trigger, exact_trigger => 1); + + if (not @factoids or not $factoids[0]) { + if ($needs_disambig) { return "/say $from_trigger not found"; } + else { + $from_chan = 'global channel' if $from_chan eq '.*'; + return "/say $from_trigger not found in $from_chan"; + } + } + + if (@factoids > 1) { + if ($needs_disambig or not grep { $_->[0] eq $from_chan } @factoids) { + unless ($opts{explicit}) { + foreach my $factoid (@factoids) { + if ($factoid->[0] eq '.*') { ($channel, $trigger) = ($factoid->[0], $factoid->[1]); } + } + } + if (not defined $channel) { + return + "/say $from_trigger found in multiple channels: " + . (join ', ', sort map { $_->[0] eq '.*' ? 'global' : $_->[0] } @factoids) + . "; use `$command $from_trigger` to disambiguate."; + } + } else { + foreach my $factoid (@factoids) { + if ($factoid->[0] eq $from_chan) { + ($channel, $trigger) = ($factoid->[0], $factoid->[1]); + last; + } + } + } + } else { + ($channel, $trigger) = ($factoids[0]->[0], $factoids[0]->[1]); + } + } + + $channel = '.*' if $channel eq 'global'; + $from_chan = '.*' if $channel eq 'global'; + + if ($opts{explicit} and $channel =~ /^#/ and $from_chan =~ /^#/ and $channel ne $from_chan) { + 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' if $channel_name eq '.*'; + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; + return "/say $trigger_name belongs to $channel_name, not $from_chan. Please switch to or explicitly specify $channel_name."; + } + return ($channel, $trigger, $remaining_args); } sub hash_differences_as_string { - my ($self, $old, $new) = @_; - my @exclude = qw/created_on last_referenced_in last_referenced_on ref_count ref_user edited_by edited_on/; - my %diff; + my ($self, $old, $new) = @_; + my @exclude = qw/created_on last_referenced_in last_referenced_on ref_count ref_user edited_by edited_on/; + my %diff; - foreach my $key (keys %$new) { - next if grep { $key eq $_ } @exclude; - if (not exists $old->{$key} or $old->{$key} ne $new->{$key}) { - $diff{$key} = $new->{$key}; + foreach my $key (keys %$new) { + next if grep { $key eq $_ } @exclude; + if (not exists $old->{$key} or $old->{$key} ne $new->{$key}) { $diff{$key} = $new->{$key}; } } - } - foreach my $key (keys %$old) { - next if grep { $key eq $_ } @exclude; - if (not exists $new->{$key}) { - $diff{"deleted $key"} = undef; + foreach my $key (keys %$old) { + next if grep { $key eq $_ } @exclude; + if (not exists $new->{$key}) { $diff{"deleted $key"} = undef; } } - } - return "No change." if not keys %diff; + return "No change." if not keys %diff; - my $changes = ""; - my $comma = ""; - foreach my $key (sort keys %diff) { - if (defined $diff{$key}) { - $changes .= "$comma$key => $diff{$key}"; - } else { - $changes .= "$comma$key"; + my $changes = ""; + my $comma = ""; + foreach my $key (sort keys %diff) { + if (defined $diff{$key}) { $changes .= "$comma$key => $diff{$key}"; } + else { $changes .= "$comma$key"; } + $comma = ", "; } - $comma = ", "; - } - return $changes + return $changes; } sub list_undo_history { - my ($self, $undos, $start_from) = @_; + my ($self, $undos, $start_from) = @_; - $start_from-- if defined $start_from; - $start_from = 0 if not defined $start_from or $start_from < 0; + $start_from-- if defined $start_from; + $start_from = 0 if not defined $start_from or $start_from < 0; - my $result = ""; - if ($start_from > @{$undos->{list}}) { - if (@{$undos->{list}} == 1) { - return "But there is only one revision available."; - } else { - return "But there are only " . @{$undos->{list}} . " revisions available."; + my $result = ""; + if ($start_from > @{$undos->{list}}) { + if (@{$undos->{list}} == 1) { return "But there is only one revision available."; } + else { return "But there are only " . @{$undos->{list}} . " revisions available."; } } - } - if ($start_from == 0) { - if ($undos->{idx} == 0) { - $result .= "*1*: "; - } else { - $result .= "1: "; + if ($start_from == 0) { + if ($undos->{idx} == 0) { $result .= "*1*: "; } + else { $result .= "1: "; } + $result .= $self->hash_differences_as_string({}, $undos->{list}->[0]) . ";\n\n"; + $start_from++; } - $result .= $self->hash_differences_as_string({}, $undos->{list}->[0]) . ";\n\n"; - $start_from++; - } - for (my $i = $start_from; $i < @{$undos->{list}}; $i++) { - if ($i == $undos->{idx}) { - $result .= "*" . ($i + 1) . "*: "; - } else { - $result .= ($i + 1) . ": "; + for (my $i = $start_from; $i < @{$undos->{list}}; $i++) { + if ($i == $undos->{idx}) { $result .= "*" . ($i + 1) . "*: "; } + else { $result .= ($i + 1) . ": "; } + $result .= $self->hash_differences_as_string($undos->{list}->[$i - 1], $undos->{list}->[$i]); + $result .= ";\n\n"; } - $result .= $self->hash_differences_as_string($undos->{list}->[$i - 1], $undos->{list}->[$i]); - $result .= ";\n\n"; - } - return $result; + return $result; } sub factundo { - my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; - my $usage = "Usage: factundo [-l [N]] [-r N] [channel] (-l list undo history, optionally starting from N; -r jump to revision N)"; - my $getopt_error; - local $SIG{__WARN__} = sub { - $getopt_error = shift; - chomp $getopt_error; - }; + my ($self, $from, $nick, $user, $host, $arguments, $stuff) = @_; + my $usage = "Usage: factundo [-l [N]] [-r N] [channel] (-l list undo history, optionally starting from N; -r jump to revision N)"; - my ($list_undos, $goto_revision); - my ($ret, $args) = GetOptionsFromString($arguments, - 'l:i' => \$list_undos, - 'r=i' => \$goto_revision); + my $getopt_error; + local $SIG{__WARN__} = sub { + $getopt_error = shift; + chomp $getopt_error; + }; - return "/say $getopt_error -- $usage" if defined $getopt_error; - return $usage if @$args > 2; - return $usage if not @$args; + my ($list_undos, $goto_revision); + my ($ret, $args) = GetOptionsFromString( + $arguments, + 'l:i' => \$list_undos, + 'r=i' => \$goto_revision + ); - $arguments = join(' ', map { $_ = "'$_'" if $_ =~ m/ /; $_; } @$args); - my $arglist = $self->{pbot}->{interpreter}->make_args($arguments); + return "/say $getopt_error -- $usage" if defined $getopt_error; + return $usage if @$args > 2; + return $usage if not @$args; - my ($channel, $trigger) = $self->find_factoid_with_optional_channel($from, $arguments, 'factundo', explicit => 1, exact_channel => 1); - my $deleted; + $arguments = join(' ', map { $_ = "'$_'" if $_ =~ m/ /; $_; } @$args); + my $arglist = $self->{pbot}->{interpreter}->make_args($arguments); + + my ($channel, $trigger) = $self->find_factoid_with_optional_channel($from, $arguments, 'factundo', explicit => 1, exact_channel => 1); + my $deleted; - if (not defined $trigger) { - # factoid not found or some error, try to continue and load undo file if it exists - $deleted = 1; - ($channel, $trigger) = $self->{pbot}->{interpreter}->split_args($arglist, 2); if (not defined $trigger) { - $trigger = $channel; - $channel = $from; - } - $channel = '.*' if $channel !~ m/^#/; - } - my $channel_path = $channel; - $channel_path = 'global' if $channel_path eq '.*'; - - my $channel_path_safe = safe_filename $channel_path; - my $trigger_safe = safe_filename $trigger; - - my $path = $self->{pbot}->{registry}->get_data('general', 'data_dir') . '/factlog'; - my $undos = eval { retrieve("$path/$trigger_safe.$channel_path_safe.undo"); }; - - 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' if $channel_name eq '.*'; - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - - if (not $undos) { - return "There are no undos available for [$channel_name] $trigger_name."; - } - - if (defined $list_undos) { - $list_undos = 1 if $list_undos == 0; - return $self->list_undo_history($undos, $list_undos); - } - - my $factoids = $self->{pbot}->{factoids}->{factoids}; - my $userinfo = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); - if ($factoids->get_data($channel, $trigger, 'locked')) { - return "/say $trigger_name is locked and cannot be reverted." if not $self->{pbot}->{capabilities}->userhas($userinfo, 'admin'); - - if ($factoids->exists($channel, $trigger, 'cap-override') and not $self->{pbot}->{capabilities}->userhas($userinfo, 'botowner')) { - return "/say $trigger_name is locked with a cap-override and cannot be reverted. Unlock the factoid first."; - } - } - - if (defined $goto_revision) { - return "Don't be absurd." if $goto_revision < 1; - if ($goto_revision > @{$undos->{list}}) { - if (@{$undos->{list}} == 1) { - return "There is only one revision available for [$channel_name] $trigger_name."; - } else { - return "There are " . @{$undos->{list}} . " revisions available for [$channel_name] $trigger_name."; - } + # factoid not found or some error, try to continue and load undo file if it exists + $deleted = 1; + ($channel, $trigger) = $self->{pbot}->{interpreter}->split_args($arglist, 2); + if (not defined $trigger) { + $trigger = $channel; + $channel = $from; + } + $channel = '.*' if $channel !~ m/^#/; } - if ($goto_revision == $undos->{idx} + 1) { - return "[$channel_name] $trigger_name is already at revision $goto_revision."; + my $channel_path = $channel; + $channel_path = 'global' if $channel_path eq '.*'; + + my $channel_path_safe = safe_filename $channel_path; + my $trigger_safe = safe_filename $trigger; + + my $path = $self->{pbot}->{registry}->get_data('general', 'data_dir') . '/factlog'; + my $undos = eval { retrieve("$path/$trigger_safe.$channel_path_safe.undo"); }; + + 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' if $channel_name eq '.*'; + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; + + if (not $undos) { return "There are no undos available for [$channel_name] $trigger_name."; } + + if (defined $list_undos) { + $list_undos = 1 if $list_undos == 0; + return $self->list_undo_history($undos, $list_undos); } - $undos->{idx} = $goto_revision - 1; - eval { store $undos, "$path/$trigger_safe.$channel_path_safe.undo"; }; - $self->{pbot}->{logger}->log("Error storing undo: $@\n") if $@; - } else { - unless ($deleted) { - return "There are no more undos remaining for [$channel_name] $trigger_name." if not $undos->{idx}; - $undos->{idx}--; - eval { store $undos, "$path/$trigger_safe.$channel_path_safe.undo"; }; - $self->{pbot}->{logger}->log("Error storing undo: $@\n") if $@; + my $factoids = $self->{pbot}->{factoids}->{factoids}; + my $userinfo = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); + if ($factoids->get_data($channel, $trigger, 'locked')) { + return "/say $trigger_name is locked and cannot be reverted." if not $self->{pbot}->{capabilities}->userhas($userinfo, 'admin'); + + if ($factoids->exists($channel, $trigger, 'cap-override') and not $self->{pbot}->{capabilities}->userhas($userinfo, 'botowner')) { + return "/say $trigger_name is locked with a cap-override and cannot be reverted. Unlock the factoid first."; + } } - } - $self->{pbot}->{factoids}->{factoids}->add($channel, $trigger, $undos->{list}->[$undos->{idx}], 0, 1); + if (defined $goto_revision) { + return "Don't be absurd." if $goto_revision < 1; + if ($goto_revision > @{$undos->{list}}) { + if (@{$undos->{list}} == 1) { return "There is only one revision available for [$channel_name] $trigger_name."; } + else { return "There are " . @{$undos->{list}} . " revisions available for [$channel_name] $trigger_name."; } + } - my $changes = $self->hash_differences_as_string($undos->{list}->[$undos->{idx} + 1], $undos->{list}->[$undos->{idx}]); - $self->log_factoid($channel, $trigger, "$nick!$user\@$host", "reverted (undo): $changes", 1); - return "[$channel_name] $trigger_name reverted (revision " . ($undos->{idx} + 1) . "): $changes\n"; + if ($goto_revision == $undos->{idx} + 1) { return "[$channel_name] $trigger_name is already at revision $goto_revision."; } + + $undos->{idx} = $goto_revision - 1; + eval { store $undos, "$path/$trigger_safe.$channel_path_safe.undo"; }; + $self->{pbot}->{logger}->log("Error storing undo: $@\n") if $@; + } else { + unless ($deleted) { + return "There are no more undos remaining for [$channel_name] $trigger_name." if not $undos->{idx}; + $undos->{idx}--; + eval { store $undos, "$path/$trigger_safe.$channel_path_safe.undo"; }; + $self->{pbot}->{logger}->log("Error storing undo: $@\n") if $@; + } + } + + $self->{pbot}->{factoids}->{factoids}->add($channel, $trigger, $undos->{list}->[$undos->{idx}], 0, 1); + + my $changes = $self->hash_differences_as_string($undos->{list}->[$undos->{idx} + 1], $undos->{list}->[$undos->{idx}]); + $self->log_factoid($channel, $trigger, "$nick!$user\@$host", "reverted (undo): $changes", 1); + return "[$channel_name] $trigger_name reverted (revision " . ($undos->{idx} + 1) . "): $changes\n"; } sub factredo { - my $self = shift; - my ($from, $nick, $user, $host, $arguments) = @_; - my $usage = "Usage: factredo [-l [N]] [-r N] [channel] (-l list undo history, optionally starting from N; -r jump to revision N)"; + my $self = shift; + my ($from, $nick, $user, $host, $arguments) = @_; - my $getopt_error; - local $SIG{__WARN__} = sub { - $getopt_error = shift; - chomp $getopt_error; - }; + my $usage = "Usage: factredo [-l [N]] [-r N] [channel] (-l list undo history, optionally starting from N; -r jump to revision N)"; - my ($list_undos, $goto_revision); - my ($ret, $args) = GetOptionsFromString($arguments, - 'l:i' => \$list_undos, - 'r=i' => \$goto_revision); + my $getopt_error; + local $SIG{__WARN__} = sub { + $getopt_error = shift; + chomp $getopt_error; + }; - return "/say $getopt_error -- $usage" if defined $getopt_error; - return $usage if @$args > 2; - return $usage if not @$args; + my ($list_undos, $goto_revision); + my ($ret, $args) = GetOptionsFromString( + $arguments, + 'l:i' => \$list_undos, + 'r=i' => \$goto_revision + ); - $arguments = join(' ', map { $_ = "'$_'" if $_ =~ m/ /; $_; } @$args); + return "/say $getopt_error -- $usage" if defined $getopt_error; + return $usage if @$args > 2; + return $usage if not @$args; - my ($channel, $trigger) = $self->find_factoid_with_optional_channel($from, $arguments, 'factredo', explicit => 1, exact_channel => 1); - return $channel if not defined $trigger; # if $trigger is not defined, $channel is an error message + $arguments = join(' ', map { $_ = "'$_'" if $_ =~ m/ /; $_; } @$args); - my $channel_path = $channel; - $channel_path = 'global' if $channel_path eq '.*'; + my ($channel, $trigger) = $self->find_factoid_with_optional_channel($from, $arguments, 'factredo', explicit => 1, exact_channel => 1); + return $channel if not defined $trigger; # if $trigger is not defined, $channel is an error message - my $channel_path_safe = safe_filename $channel_path; - my $trigger_safe = safe_filename $trigger; + my $channel_path = $channel; + $channel_path = 'global' if $channel_path eq '.*'; - 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' if $channel_name eq '.*'; - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; + my $channel_path_safe = safe_filename $channel_path; + my $trigger_safe = safe_filename $trigger; - my $path = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/factlog'; - my $undos = eval { retrieve("$path/$trigger_safe.$channel_path_safe.undo"); }; + 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' if $channel_name eq '.*'; + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - if (not $undos) { - return "There are no redos available for [$channel_name] $trigger_name."; - } + my $path = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/factlog'; + my $undos = eval { retrieve("$path/$trigger_safe.$channel_path_safe.undo"); }; - if (defined $list_undos) { - $list_undos = 1 if $list_undos == 0; - return $self->list_undo_history($undos, $list_undos); - } + if (not $undos) { return "There are no redos available for [$channel_name] $trigger_name."; } - my $factoids = $self->{pbot}->{factoids}->{factoids}; - my $userinfo = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); - if ($factoids->get_data($channel, $trigger, 'locked')) { - return "/say $trigger_name is locked and cannot be reverted." if not defined $self->{pbot}->{capabilities}->userhas($userinfo, 'admin'); - - if ($factoids->exists($channel, $trigger, 'cap-override') and not $self->{pbot}->{capabilities}->userhas($userinfo, 'botowner')) { - return "/say $trigger_name is locked with a cap-override and cannot be reverted. Unlock the factoid first."; - } - } - - if (not defined $goto_revision and $undos->{idx} + 1 == @{$undos->{list}}) { - return "There are no more redos remaining for [$channel_name] $trigger_name."; - } - - if (defined $goto_revision) { - return "Don't be absurd." if $goto_revision < 1; - if ($goto_revision > @{$undos->{list}}) { - if (@{$undos->{list}} == 1) { - return "There is only one revision available for [$channel_name] $trigger_name."; - } else { - return "There are " . @{$undos->{list}} . " revisions available for [$channel_name] $trigger_name."; - } + if (defined $list_undos) { + $list_undos = 1 if $list_undos == 0; + return $self->list_undo_history($undos, $list_undos); } - if ($goto_revision == $undos->{idx} + 1) { - return "[$channel_name] $trigger_name is already at revision $goto_revision."; + my $factoids = $self->{pbot}->{factoids}->{factoids}; + my $userinfo = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); + if ($factoids->get_data($channel, $trigger, 'locked')) { + return "/say $trigger_name is locked and cannot be reverted." if not defined $self->{pbot}->{capabilities}->userhas($userinfo, 'admin'); + + if ($factoids->exists($channel, $trigger, 'cap-override') and not $self->{pbot}->{capabilities}->userhas($userinfo, 'botowner')) { + return "/say $trigger_name is locked with a cap-override and cannot be reverted. Unlock the factoid first."; + } } - $undos->{idx} = $goto_revision - 1; - eval { store $undos, "$path/$trigger_safe.$channel_path_safe.undo"; }; - $self->{pbot}->{logger}->log("Error storing undo: $@\n") if $@; - } else { - $undos->{idx}++; - eval { store $undos, "$path/$trigger_safe.$channel_path_safe.undo"; }; - $self->{pbot}->{logger}->log("Error storing undo: $@\n") if $@; - } + if (not defined $goto_revision and $undos->{idx} + 1 == @{$undos->{list}}) { return "There are no more redos remaining for [$channel_name] $trigger_name."; } - $self->{pbot}->{factoids}->{factoids}->add($channel, $trigger, $undos->{list}->[$undos->{idx}], 0, 1); + if (defined $goto_revision) { + return "Don't be absurd." if $goto_revision < 1; + if ($goto_revision > @{$undos->{list}}) { + if (@{$undos->{list}} == 1) { return "There is only one revision available for [$channel_name] $trigger_name."; } + else { return "There are " . @{$undos->{list}} . " revisions available for [$channel_name] $trigger_name."; } + } - my $changes = $self->hash_differences_as_string($undos->{list}->[$undos->{idx} - 1], $undos->{list}->[$undos->{idx}]); - $self->log_factoid($channel, $trigger, "$nick!$user\@$host", "reverted (redo): $changes", 1); - return "[$channel_name] $trigger_name restored (revision " . ($undos->{idx} + 1) . "): $changes\n"; + if ($goto_revision == $undos->{idx} + 1) { return "[$channel_name] $trigger_name is already at revision $goto_revision."; } + + $undos->{idx} = $goto_revision - 1; + eval { store $undos, "$path/$trigger_safe.$channel_path_safe.undo"; }; + $self->{pbot}->{logger}->log("Error storing undo: $@\n") if $@; + } else { + $undos->{idx}++; + eval { store $undos, "$path/$trigger_safe.$channel_path_safe.undo"; }; + $self->{pbot}->{logger}->log("Error storing undo: $@\n") if $@; + } + + $self->{pbot}->{factoids}->{factoids}->add($channel, $trigger, $undos->{list}->[$undos->{idx}], 0, 1); + + my $changes = $self->hash_differences_as_string($undos->{list}->[$undos->{idx} - 1], $undos->{list}->[$undos->{idx}]); + $self->log_factoid($channel, $trigger, "$nick!$user\@$host", "reverted (redo): $changes", 1); + return "[$channel_name] $trigger_name restored (revision " . ($undos->{idx} + 1) . "): $changes\n"; } sub factset { - my $self = shift; - my ($from, $nick, $user, $host, $args) = @_; + my $self = shift; + my ($from, $nick, $user, $host, $args) = @_; - my ($channel, $trigger, $arguments) = $self->find_factoid_with_optional_channel($from, $args, 'factset', usage => 'Usage: factset [channel] [key [value]]', explicit => 1); - return $channel if not defined $trigger; # if $trigger is not defined, $channel is an error message + my ($channel, $trigger, $arguments) = + $self->find_factoid_with_optional_channel($from, $args, 'factset', usage => 'Usage: factset [channel] [key [value]]', explicit => 1); + return $channel if not defined $trigger; # if $trigger is not defined, $channel is an error message - my $trigger_name = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, '_name'); - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; + my $trigger_name = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, '_name'); + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - my $arglist = $self->{pbot}->{interpreter}->make_args($arguments); - my ($key, $value) = $self->{pbot}->{interpreter}->split_args($arglist, 2); + my $arglist = $self->{pbot}->{interpreter}->make_args($arguments); + my ($key, $value) = $self->{pbot}->{interpreter}->split_args($arglist, 2); - $channel = '.*' if $channel !~ /^#/; - my ($owner_channel, $owner_trigger) = $self->{pbot}->{factoids}->find_factoid($channel, $trigger, exact_channel => 1, exact_trigger => 1); + $channel = '.*' if $channel !~ /^#/; + my ($owner_channel, $owner_trigger) = $self->{pbot}->{factoids}->find_factoid($channel, $trigger, exact_channel => 1, exact_trigger => 1); - my $userinfo; - if (defined $owner_channel) { - $userinfo = $self->{pbot}->{users}->loggedin($owner_channel, "$nick!$user\@$host"); - } else { - $userinfo = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); - } + my $userinfo; + if (defined $owner_channel) { $userinfo = $self->{pbot}->{users}->loggedin($owner_channel, "$nick!$user\@$host"); } + else { $userinfo = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); } - my $meta_cap; - if (defined $key) { - if (defined $factoid_metadata_capabilities{$key}) { - $meta_cap = $factoid_metadata_capabilities{$key}; + my $meta_cap; + if (defined $key) { + if (defined $factoid_metadata_capabilities{$key}) { $meta_cap = $factoid_metadata_capabilities{$key}; } + + if (defined $meta_cap) { + if (not $self->{pbot}->{capabilities}->userhas($userinfo, $meta_cap)) { return "Your user account must have the $meta_cap capability to set $key."; } + } + + if (defined $value and !$self->{pbot}->{capabilities}->userhas($userinfo, 'admin') and $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, 'locked')) { + return "/say $trigger_name is locked; unlock before setting."; + } + + if (lc $key eq 'cap-override' and defined $value) { + if (not $self->{pbot}->{capabilities}->exists($value)) { return "No such capability $value."; } + $self->{pbot}->{factoids}->{factoids}->set($channel, $trigger, 'locked', '1'); + } + + if (lc $key eq 'locked' and $self->{pbot}->{factoids}->{factoids}->exists($channel, $trigger, 'cap-override')) { + if (not $self->{pbot}->{capabilities}->userhas($userinfo, 'botowner')) { + return "/say $trigger_name has a cap-override and cannot be unlocked until the override is removed."; + } + } } - if (defined $meta_cap) { - if (not $self->{pbot}->{capabilities}->userhas($userinfo, $meta_cap)) { - return "Your user account must have the $meta_cap capability to set $key."; - } + if (defined $owner_channel) { + my $factoid = $self->{pbot}->{factoids}->{factoids}->get_data($owner_channel, $owner_trigger); + + my $owner; + my $mask; + if ($factoid->{'locked'}) { + + # check owner against full hostmask for locked factoids + $owner = $factoid->{'owner'}; + $mask = "$nick!$user\@$host"; + } else { + + # otherwise just the nick + ($owner) = $factoid->{'owner'} =~ m/([^!]+)/; + $mask = $nick; + } + + if ((defined $value and $key ne 'action' and $key ne 'action_with_args') and lc $mask ne lc $owner and not $self->{pbot}->{capabilities}->userhas($userinfo, 'admin')) { + return "You are not the owner of $trigger_name."; + } } - if (defined $value and !$self->{pbot}->{capabilities}->userhas($userinfo, 'admin') and $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, 'locked')) { - return "/say $trigger_name is locked; unlock before setting."; - } + my $result = $self->{pbot}->{factoids}->{factoids}->set($channel, $trigger, $key, $value); - if (lc $key eq 'cap-override' and defined $value) { - if (not $self->{pbot}->{capabilities}->exists($value)) { - return "No such capability $value."; - } - $self->{pbot}->{factoids}->{factoids}->set($channel, $trigger, 'locked', '1'); - } + if (defined $value and $result =~ m/set to/) { $self->log_factoid($channel, $trigger, "$nick!$user\@$host", "set $key to $value"); } - if (lc $key eq 'locked' and $self->{pbot}->{factoids}->{factoids}->exists($channel, $trigger, 'cap-override')) { - if (not $self->{pbot}->{capabilities}->userhas($userinfo, 'botowner')) { - return "/say $trigger_name has a cap-override and cannot be unlocked until the override is removed."; - } - } - } - - if (defined $owner_channel) { - my $factoid = $self->{pbot}->{factoids}->{factoids}->get_data($owner_channel, $owner_trigger); - - my $owner; - my $mask; - if ($factoid->{'locked'}) { - # check owner against full hostmask for locked factoids - $owner = $factoid->{'owner'}; - $mask = "$nick!$user\@$host"; - } else { - # otherwise just the nick - ($owner) = $factoid->{'owner'} =~ m/([^!]+)/; - $mask = $nick; - } - - if ((defined $value and $key ne 'action' and $key ne 'action_with_args') and lc $mask ne lc $owner and not $self->{pbot}->{capabilities}->userhas($userinfo, 'admin')) { - return "You are not the owner of $trigger_name."; - } - } - - my $result = $self->{pbot}->{factoids}->{factoids}->set($channel, $trigger, $key, $value); - - if (defined $value and $result =~ m/set to/) { - $self->log_factoid($channel, $trigger, "$nick!$user\@$host", "set $key to $value"); - } - - return $result; + return $result; } sub factunset { - my $self = shift; - my ($from, $nick, $user, $host, $args) = @_; - my $usage = 'Usage: factunset [channel] '; - my ($channel, $trigger, $arguments) = $self->find_factoid_with_optional_channel($from, $args, 'factunset', usage => $usage, explicit => 1); - return $channel if not defined $trigger; # if $trigger is not defined, $channel is an error message - my ($key) = $self->{pbot}->{interpreter}->split_line($arguments, strip_quotes => 1); - return $usage if not length $key; + my $self = shift; + my ($from, $nick, $user, $host, $args) = @_; + my $usage = 'Usage: factunset [channel] '; + my ($channel, $trigger, $arguments) = $self->find_factoid_with_optional_channel($from, $args, 'factunset', usage => $usage, explicit => 1); + return $channel if not defined $trigger; # if $trigger is not defined, $channel is an error message + my ($key) = $self->{pbot}->{interpreter}->split_line($arguments, strip_quotes => 1); + return $usage if not length $key; - my ($owner_channel, $owner_trigger) = $self->{pbot}->{factoids}->find_factoid($channel, $trigger, exact_channel => 1, exact_trigger => 1); - my $userinfo; - if (defined $owner_channel) { - $userinfo = $self->{pbot}->{users}->loggedin($owner_channel, "$nick!$user\@$host"); - } else { - $userinfo = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); - } + my ($owner_channel, $owner_trigger) = $self->{pbot}->{factoids}->find_factoid($channel, $trigger, exact_channel => 1, exact_trigger => 1); + my $userinfo; + if (defined $owner_channel) { $userinfo = $self->{pbot}->{users}->loggedin($owner_channel, "$nick!$user\@$host"); } + else { $userinfo = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); } - my $meta_cap; - if (exists $factoid_metadata_capabilities{$key}) { - $meta_cap = $factoid_metadata_capabilities{$key}; - } + my $meta_cap; + if (exists $factoid_metadata_capabilities{$key}) { $meta_cap = $factoid_metadata_capabilities{$key}; } - if (defined $meta_cap) { - if (not $self->{pbot}->{capabilities}->userhas($userinfo, $meta_cap)) { - return "Your user account must have the $meta_cap capability to unset $key."; + if (defined $meta_cap) { + if (not $self->{pbot}->{capabilities}->userhas($userinfo, $meta_cap)) { return "Your user account must have the $meta_cap capability to unset $key."; } } - } - if ($self->{pbot}->{factoids}->{factoids}->exists($channel, $trigger, 'cap-override')) { - if (lc $key eq 'locked') { - if ($self->{pbot}->{capabilities}->userhas($userinfo, 'botowner')) { - $self->{pbot}->{factoids}->{factoids}->unset($channel, $trigger, 'cap-override', 1); - } else { - return "You cannot unlock this factoid because it has a cap-override. Remove the override first."; - } + if ($self->{pbot}->{factoids}->{factoids}->exists($channel, $trigger, 'cap-override')) { + if (lc $key eq 'locked') { + if ($self->{pbot}->{capabilities}->userhas($userinfo, 'botowner')) { $self->{pbot}->{factoids}->{factoids}->unset($channel, $trigger, 'cap-override', 1); } + else { return "You cannot unlock this factoid because it has a cap-override. Remove the override first."; } + } } - } - 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' if $channel_name eq '.*'; - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; + 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' if $channel_name eq '.*'; + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - my $oldvalue; - if (defined $owner_channel) { - my $factoid = $self->{pbot}->{factoids}->{factoids}->get_data($owner_channel, $owner_trigger); - my ($owner) = $factoid->{'owner'} =~ m/([^!]+)/; - if ($key ne 'action_with_args' and lc $nick ne lc $owner and not $self->{pbot}->{capabilities}->userhas($userinfo, 'admin')) { - return "You are not the owner of $trigger_name."; + my $oldvalue; + if (defined $owner_channel) { + my $factoid = $self->{pbot}->{factoids}->{factoids}->get_data($owner_channel, $owner_trigger); + my ($owner) = $factoid->{'owner'} =~ m/([^!]+)/; + if ($key ne 'action_with_args' and lc $nick ne lc $owner and not $self->{pbot}->{capabilities}->userhas($userinfo, 'admin')) { + return "You are not the owner of $trigger_name."; + } + $oldvalue = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, $key); } - $oldvalue = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, $key); - } - return "[$channel_name] $trigger_name: key '$key' does not exist." if not defined $oldvalue; - my $result = $self->{pbot}->{factoids}->{factoids}->unset($channel, $trigger, $key); - if ($result =~ m/unset/) { - $self->log_factoid($channel, $trigger, "$nick!$user\@$host", "unset $key (value: $oldvalue)"); - } - return $result; + return "[$channel_name] $trigger_name: key '$key' does not exist." if not defined $oldvalue; + my $result = $self->{pbot}->{factoids}->{factoids}->unset($channel, $trigger, $key); + if ($result =~ m/unset/) { $self->log_factoid($channel, $trigger, "$nick!$user\@$host", "unset $key (value: $oldvalue)"); } + return $result; } sub factmove { - my $self = shift; - my ($from, $nick, $user, $host, $arguments, $stuff) = @_; - my ($src_channel, $source, $target_channel, $target) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 5); - my $usage = "Usage: factmove [target factoid]"; - return $usage if not defined $target_channel; + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my ($src_channel, $source, $target_channel, $target) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 5); + my $usage = "Usage: factmove [target factoid]"; + return $usage if not defined $target_channel; - if ($target_channel !~ /^#/ and $target_channel ne '.*') { - if (defined $target) { - return "Unexpected argument '$target' when renaming to '$target_channel'. Perhaps '$target_channel' is missing #s? $usage"; + if ($target_channel !~ /^#/ and $target_channel ne '.*') { + if (defined $target) { return "Unexpected argument '$target' when renaming to '$target_channel'. Perhaps '$target_channel' is missing #s? $usage"; } + $target = $target_channel; + $target_channel = $src_channel; + } else { + if (not defined $target) { $target = $source; } } - $target = $target_channel; - $target_channel = $src_channel; - } else { - if (not defined $target) { - $target = $source; + + if (length $target > $self->{pbot}->{registry}->get_value('factoids', 'max_name_length')) { return "/say $nick: I don't think the factoid name needs to be that long."; } + + if (length $target_channel > $self->{pbot}->{registry}->get_value('factoids', 'max_channel_length')) { + return "/say $nick: I don't think the channel name needs to be that long."; } - } - if (length $target > $self->{pbot}->{registry}->get_value('factoids', 'max_name_length')) { - return "/say $nick: I don't think the factoid name needs to be that long."; - } + my ($found_src_channel, $found_source) = $self->{pbot}->{factoids}->find_factoid($src_channel, $source, exact_channel => 1, exact_trigger => 1); - if (length $target_channel > $self->{pbot}->{registry}->get_value('factoids', 'max_channel_length')) { - return "/say $nick: I don't think the channel name needs to be that long."; - } + if (not defined $found_src_channel) { return "Source factoid $source not found in channel $src_channel"; } - my ($found_src_channel, $found_source) = $self->{pbot}->{factoids}->find_factoid($src_channel, $source, exact_channel => 1, exact_trigger => 1); + my $source_channel_name = $self->{pbot}->{factoids}->{factoids}->get_data($found_src_channel, '_name'); + my $source_trigger_name = $self->{pbot}->{factoids}->{factoids}->get_data($found_src_channel, $found_source, '_name'); + $source_channel_name = 'global' if $source_channel_name eq '.*'; + $source_trigger_name = "\"$source_trigger_name\"" if $source_trigger_name =~ / /; - if (not defined $found_src_channel) { - return "Source factoid $source not found in channel $src_channel"; - } + my $factoids = $self->{pbot}->{factoids}->{factoids}; + my ($owner) = $factoids->get_data($found_src_channel, $found_source, 'owner') =~ m/([^!]+)/; - my $source_channel_name = $self->{pbot}->{factoids}->{factoids}->get_data($found_src_channel, '_name'); - my $source_trigger_name = $self->{pbot}->{factoids}->{factoids}->get_data($found_src_channel, $found_source, '_name'); - $source_channel_name = 'global' if $source_channel_name eq '.*'; - $source_trigger_name = "\"$source_trigger_name\"" if $source_trigger_name =~ / /; + if ((lc $nick ne lc $owner) and (not $self->{pbot}->{users}->loggedin_admin($found_src_channel, "$nick!$user\@$host"))) { + $self->{pbot}->{logger}->log("$nick!$user\@$host attempted to move [$found_src_channel] $found_source (not owner)\n"); + my $chan = ($found_src_channel eq '.*' ? 'the global channel' : $found_src_channel); + return "You are not the owner of $source_trigger_name for $source_channel_name."; + } - my $factoids = $self->{pbot}->{factoids}->{factoids}; - my ($owner) = $factoids->get_data($found_src_channel, $found_source, 'owner') =~ m/([^!]+)/; + if ($factoids->get_data($found_src_channel, $found_source, 'locked')) { return "/say $source_trigger_name is locked; unlock before moving."; } - if ((lc $nick ne lc $owner) and (not $self->{pbot}->{users}->loggedin_admin($found_src_channel, "$nick!$user\@$host"))) { - $self->{pbot}->{logger}->log("$nick!$user\@$host attempted to move [$found_src_channel] $found_source (not owner)\n"); - my $chan = ($found_src_channel eq '.*' ? 'the global channel' : $found_src_channel); - return "You are not the owner of $source_trigger_name for $source_channel_name."; - } + my ($found_target_channel, $found_target) = $self->{pbot}->{factoids}->find_factoid($target_channel, $target, exact_channel => 1, exact_trigger => 1); - if ($factoids->get_data($found_src_channel, $found_source, 'locked')) { - return "/say $source_trigger_name is locked; unlock before moving."; - } + if (defined $found_target_channel) { + my $target_channel_name = $factoids->get_data($found_target_channel, '_name'); + my $target_trigger_name = $factoids->get_data($found_target_channel, $found_target, '_name'); + $target_channel_name = 'global' if $target_channel_name eq '.*'; + $target_trigger_name = "\"$target_trigger_name\"" if $target_trigger_name =~ / /; + return "Target factoid $target_trigger_name already exists in channel $target_channel_name."; + } - my ($found_target_channel, $found_target) = $self->{pbot}->{factoids}->find_factoid($target_channel, $target, exact_channel => 1, exact_trigger => 1); + my ($overchannel, $overtrigger) = $self->{pbot}->{factoids}->find_factoid('.*', $target, exact_channel => 1, exact_trigger => 1); + if (defined $overtrigger and $factoids->get_data('.*', $overtrigger, 'nooverride')) { + my $override_channel_name = $factoids->get_data($overchannel, '_name'); + my $override_trigger_name = $factoids->get_data($overchannel, $overtrigger, '_name'); + $override_channel_name = 'global' if $override_channel_name eq '.*'; + $override_trigger_name = "\"$override_trigger_name\"" if $override_trigger_name =~ / /; + $self->{pbot}->{logger}->log("$nick!$user\@$host attempt to override $target\n"); + return + "/say $override_trigger_name already exists for the global channel and cannot be overridden for " + . ($target_channel eq '.*' ? 'the global channel' : $target_channel) . "."; + } - if (defined $found_target_channel) { - my $target_channel_name = $factoids->get_data($found_target_channel, '_name'); - my $target_trigger_name = $factoids->get_data($found_target_channel, $found_target, '_name'); - $target_channel_name = 'global' if $target_channel_name eq '.*'; - $target_trigger_name = "\"$target_trigger_name\"" if $target_trigger_name =~ / /; - return "Target factoid $target_trigger_name already exists in channel $target_channel_name."; - } + if ($self->{pbot}->{commands}->exists($target)) { return "/say $target already exists as a built-in command."; } - my ($overchannel, $overtrigger) = $self->{pbot}->{factoids}->find_factoid('.*', $target, exact_channel => 1, exact_trigger => 1); - if (defined $overtrigger and $factoids->get_data('.*', $overtrigger, 'nooverride')) { - my $override_channel_name = $factoids->get_data($overchannel, '_name'); - my $override_trigger_name = $factoids->get_data($overchannel, $overtrigger, '_name'); - $override_channel_name = 'global' if $override_channel_name eq '.*'; - $override_trigger_name = "\"$override_trigger_name\"" if $override_trigger_name =~ / /; - $self->{pbot}->{logger}->log("$nick!$user\@$host attempt to override $target\n"); - return "/say $override_trigger_name already exists for the global channel and cannot be overridden for " . ($target_channel eq '.*' ? 'the global channel' : $target_channel) . "."; - } + $target_channel = '.*' if $target_channel !~ /^#/; - if ($self->{pbot}->{commands}->exists($target)) { - return "/say $target already exists as a built-in command."; - } + my $data = $factoids->get_data($found_src_channel, $found_source); + $factoids->remove($found_src_channel, $found_source, undef, 1); + $factoids->add($target_channel, $target, $data, 0, 1); - $target_channel = '.*' if $target_channel !~ /^#/; + $found_src_channel = 'global' if $found_src_channel eq '.*'; + $target_channel = 'global' if $target_channel eq '.*'; - my $data = $factoids->get_data($found_src_channel, $found_source); - $factoids->remove($found_src_channel, $found_source, undef, 1); - $factoids->add($target_channel, $target, $data, 0, 1); - - $found_src_channel = 'global' if $found_src_channel eq '.*'; - $target_channel = 'global' if $target_channel eq '.*'; - - if ($src_channel eq lc $target_channel) { - $self->log_factoid($found_src_channel, $found_source, "$nick!$user\@$host", "renamed from $source_trigger_name to $target"); - $self->log_factoid($target_channel, $target, "$nick!$user\@$host", "renamed from $source_trigger_name to $target"); - return "[$source_channel_name] $source_trigger_name renamed to $target"; - } else { - $self->log_factoid($found_src_channel, $found_source, "$nick!$user\@$host", "moved from $source_channel_name/$source_trigger_name to $target_channel/$target"); - $self->log_factoid($target_channel, $target, "$nick!$user\@$host", "moved from $source_channel_name/$source_trigger_name to $target_channel/$target"); - return "[$source_channel_name] $source_trigger_name moved to [$target_channel] $target"; - } + if ($src_channel eq lc $target_channel) { + $self->log_factoid($found_src_channel, $found_source, "$nick!$user\@$host", "renamed from $source_trigger_name to $target"); + $self->log_factoid($target_channel, $target, "$nick!$user\@$host", "renamed from $source_trigger_name to $target"); + return "[$source_channel_name] $source_trigger_name renamed to $target"; + } else { + $self->log_factoid($found_src_channel, $found_source, "$nick!$user\@$host", "moved from $source_channel_name/$source_trigger_name to $target_channel/$target"); + $self->log_factoid($target_channel, $target, "$nick!$user\@$host", "moved from $source_channel_name/$source_trigger_name to $target_channel/$target"); + return "[$source_channel_name] $source_trigger_name moved to [$target_channel] $target"; + } } sub factalias { - my $self = shift; - my ($from, $nick, $user, $host, $arguments, $stuff) = @_; - my ($chan, $alias, $command) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3, 0, 1); + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my ($chan, $alias, $command) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 3, 0, 1); - if (defined $chan and not ($chan eq '.*' or $chan =~ m/^#/)) { - # $chan doesn't look like a channel, so shift everything to the right - # and replace $chan with $from - if (defined $command and length $command) { - $command = "$alias $command"; - } else { - $command = $alias; + if (defined $chan and not($chan eq '.*' or $chan =~ m/^#/)) { + + # $chan doesn't look like a channel, so shift everything to the right + # and replace $chan with $from + if (defined $command and length $command) { $command = "$alias $command"; } + else { $command = $alias; } + $alias = $chan; + $chan = $from; } - $alias = $chan; - $chan = $from; - } - $chan = '.*' if $chan !~ /^#/; - return "Usage: factalias [channel] " if not length $alias or not length $command; + $chan = '.*' if $chan !~ /^#/; + return "Usage: factalias [channel] " if not length $alias or not length $command; - if (length $alias > $self->{pbot}->{registry}->get_value('factoids', 'max_name_length')) { - return "/say $nick: I don't think the factoid name needs to be that long."; - } + if (length $alias > $self->{pbot}->{registry}->get_value('factoids', 'max_name_length')) { return "/say $nick: I don't think the factoid name needs to be that long."; } - if (length $chan > $self->{pbot}->{registry}->get_value('factoids', 'max_channel_length')) { - return "/say $nick: I don't think the channel name needs to be that long."; - } + if (length $chan > $self->{pbot}->{registry}->get_value('factoids', 'max_channel_length')) { return "/say $nick: I don't think the channel name needs to be that long."; } - my ($channel, $alias_trigger) = $self->{pbot}->{factoids}->find_factoid($chan, $alias, exact_channel => 1, exact_trigger => 1); - if (defined $alias_trigger) { - my $alias_channel_name = $self->{pbot}->{factoids}->{factoids}->get_data($channel, '_name'); - my $alias_trigger_name = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $alias_trigger, '_name'); - $alias_channel_name = 'global' if $alias_channel_name eq '.*'; - $alias_trigger_name = "\"$alias_trigger_name\"" if $alias_trigger_name =~ / /; - return "$alias_trigger_name already exists for $alias_channel_name."; - } + my ($channel, $alias_trigger) = $self->{pbot}->{factoids}->find_factoid($chan, $alias, exact_channel => 1, exact_trigger => 1); + if (defined $alias_trigger) { + my $alias_channel_name = $self->{pbot}->{factoids}->{factoids}->get_data($channel, '_name'); + my $alias_trigger_name = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $alias_trigger, '_name'); + $alias_channel_name = 'global' if $alias_channel_name eq '.*'; + $alias_trigger_name = "\"$alias_trigger_name\"" if $alias_trigger_name =~ / /; + return "$alias_trigger_name already exists for $alias_channel_name."; + } - my ($overchannel, $overtrigger) = $self->{pbot}->{factoids}->find_factoid('.*', $alias, exact_channel => 1, exact_trigger => 1); - if (defined $overtrigger and $self->{pbot}->{factoids}->{factoids}->get_data('.*', $overtrigger, 'nooverride')) { - my $override_trigger_name = $self->{pbot}->{factoids}->{factoids}->get_data($overchannel, $overtrigger, '_name'); - $override_trigger_name = "\"$override_trigger_name\"" if $override_trigger_name =~ / /; - return "/say $override_trigger_name already exists for the global channel and cannot be overridden for " . ($chan eq '.*' ? 'the global channel' : $chan) . "."; - } + my ($overchannel, $overtrigger) = $self->{pbot}->{factoids}->find_factoid('.*', $alias, exact_channel => 1, exact_trigger => 1); + if (defined $overtrigger and $self->{pbot}->{factoids}->{factoids}->get_data('.*', $overtrigger, 'nooverride')) { + my $override_trigger_name = $self->{pbot}->{factoids}->{factoids}->get_data($overchannel, $overtrigger, '_name'); + $override_trigger_name = "\"$override_trigger_name\"" if $override_trigger_name =~ / /; + return "/say $override_trigger_name already exists for the global channel and cannot be overridden for " . ($chan eq '.*' ? 'the global channel' : $chan) . "."; + } - if ($self->{pbot}->{commands}->exists($alias)) { - return "/say $alias already exists as a built-in command."; - } + if ($self->{pbot}->{commands}->exists($alias)) { return "/say $alias already exists as a built-in command."; } - $self->{pbot}->{factoids}->add_factoid('text', $chan, "$nick!$user\@$host", $alias, "/call $command"); - $self->{pbot}->{logger}->log("$nick!$user\@$host [$chan] aliased $alias => $command\n"); - $self->{pbot}->{factoids}->save_factoids(); - return "$alias aliases `$command` for " . ($chan eq '.*' ? 'the global channel' : $chan); + $self->{pbot}->{factoids}->add_factoid('text', $chan, "$nick!$user\@$host", $alias, "/call $command"); + $self->{pbot}->{logger}->log("$nick!$user\@$host [$chan] aliased $alias => $command\n"); + $self->{pbot}->{factoids}->save_factoids(); + return "$alias aliases `$command` for " . ($chan eq '.*' ? 'the global channel' : $chan); } sub add_regex { - my $self = shift; - my ($from, $nick, $user, $host, $arguments) = @_; - my $factoids = $self->{pbot}->{factoids}->{factoids}; - my ($keyword, $text) = $arguments =~ /^(.*?)\s+(.*)$/ if defined $arguments; + my $self = shift; + my ($from, $nick, $user, $host, $arguments) = @_; + my $factoids = $self->{pbot}->{factoids}->{factoids}; + my ($keyword, $text) = $arguments =~ /^(.*?)\s+(.*)$/ if defined $arguments; - $from = '.*' if not defined $from or $from !~ /^#/; + $from = '.*' if not defined $from or $from !~ /^#/; - if (not defined $keyword) { - $text = ""; - foreach my $trigger (sort $factoids->get_keys($from)) { - if ($factoids->get_data($from, $trigger, 'type') eq 'regex') { - $text .= $trigger . " "; - } + if (not defined $keyword) { + $text = ""; + foreach my $trigger (sort $factoids->get_keys($from)) { + if ($factoids->get_data($from, $trigger, 'type') eq 'regex') { $text .= $trigger . " "; } + } + return "Stored regexs for channel $from: $text"; } - return "Stored regexs for channel $from: $text"; - } - if (not defined $text) { - return "Usage: regex "; - } + if (not defined $text) { return "Usage: regex "; } - my ($channel, $trigger) = $self->{pbot}->{factoids}->find_factoid($from, $keyword, exact_channel => 1, exact_trigger => 1); + my ($channel, $trigger) = $self->{pbot}->{factoids}->find_factoid($from, $keyword, exact_channel => 1, exact_trigger => 1); - if (defined $trigger) { - $self->{pbot}->{logger}->log("$nick!$user\@$host attempt to overwrite $trigger\n"); - return "/say $trigger already exists for channel $channel."; - } + if (defined $trigger) { + $self->{pbot}->{logger}->log("$nick!$user\@$host attempt to overwrite $trigger\n"); + return "/say $trigger already exists for channel $channel."; + } - $self->{pbot}->{factoids}->add_factoid('regex', $from, "$nick!$user\@$host", $keyword, $text); - $self->{pbot}->{logger}->log("$nick!$user\@$host added [$keyword] => [$text]\n"); - return "/say $keyword added."; + $self->{pbot}->{factoids}->add_factoid('regex', $from, "$nick!$user\@$host", $keyword, $text); + $self->{pbot}->{logger}->log("$nick!$user\@$host added [$keyword] => [$text]\n"); + return "/say $keyword added."; } sub factadd { - my $self = shift; - my ($from, $nick, $user, $host, $arguments, $stuff) = @_; - my ($from_chan, $keyword, $text, $force); + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my ($from_chan, $keyword, $text, $force); - my @arglist = @{$stuff->{arglist}}; + my @arglist = @{$stuff->{arglist}}; - if (@arglist) { - # check for -f since we allow it to be before optional channel argument - if ($arglist[0] eq '-f') { - $force = 1; - $self->{pbot}->{interpreter}->shift_arg(\@arglist); + if (@arglist) { + + # check for -f since we allow it to be before optional channel argument + if ($arglist[0] eq '-f') { + $force = 1; + $self->{pbot}->{interpreter}->shift_arg(\@arglist); + } + + # check if this is an optional channel argument + if ($arglist[0] =~ m/(?:^#|^global$|^\.\*$)/i) { $from_chan = $self->{pbot}->{interpreter}->shift_arg(\@arglist); } + else { $from_chan = $from; } + + # check for -f again since we also allow it to appear after the channel argument + if ($arglist[0] eq '-f') { + $force = 1; + $self->{pbot}->{interpreter}->shift_arg(\@arglist); + } + + # now this is the keyword + $keyword = $self->{pbot}->{interpreter}->shift_arg(\@arglist); + + # check for -url + if ($arglist[0] eq '-url') { + + # discard it + $self->{pbot}->{interpreter}->shift_arg(\@arglist); + + # the URL is the remaining arguments + my ($url) = $self->{pbot}->{interpreter}->split_args(\@arglist, 1); + + # FIXME: move this to registry + if ($url !~ m/^https?:\/\/(?:sprunge.us|ix.io)\/\w+$/) { return "Invalid URL: acceptable URLs are: http://sprunge.us, http://ix.io"; } + + # create a UserAgent + my $ua = LWP::UserAgent->new(timeout => 10); + + # get the factoid's text from the URL + my $response = $ua->get($url); + + # process the response + if ($response->is_success) { $text = $response->decoded_content; } + else { return "Failed to get URL: " . $response->status_line; } + } else { + + # check for optional "is" and discard + if (lc $arglist[0] eq 'is') { $self->{pbot}->{interpreter}->shift_arg(\@arglist); } + + # and the text is the remaining arguments with quotes preserved + ($text) = $self->{pbot}->{interpreter}->split_args(\@arglist, 1, 0, 1); + } } - # check if this is an optional channel argument - if ($arglist[0] =~ m/(?:^#|^global$|^\.\*$)/i) { - $from_chan = $self->{pbot}->{interpreter}->shift_arg(\@arglist); - } else { - $from_chan = $from; + if (not defined $from_chan or not defined $text or not defined $keyword) { + return "Usage: factadd [-f] [channel] ( | -url ); -f to force overwrite; -url to download from paste site"; } - # check for -f again since we also allow it to appear after the channel argument - if ($arglist[0] eq '-f') { - $force = 1; - $self->{pbot}->{interpreter}->shift_arg(\@arglist); + $from_chan = '.*' if $from_chan !~ /^#/; + + if (length $keyword > $self->{pbot}->{registry}->get_value('factoids', 'max_name_length')) { return "/say $nick: I don't think the factoid name needs to be that long."; } + + if (length $from_chan > $self->{pbot}->{registry}->get_value('factoids', 'max_channel_length')) { return "/say $nick: I don't think the channel needs to be that long."; } + + $from_chan = '.*' if lc $from_chan eq 'global'; + $from_chan = '.*' if not $from_chan =~ m/^#/; + + my $keyword_text = $keyword =~ / / ? "\"$keyword\"" : $keyword; + + my ($channel, $trigger) = $self->{pbot}->{factoids}->find_factoid($from_chan, $keyword, exact_channel => 1, exact_trigger => 1); + if (defined $trigger) { + 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' if $channel_name eq '.*'; + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; + + if (not $force) { return "/say $trigger_name already exists for $channel_name."; } + else { + my $factoids = $self->{pbot}->{factoids}->{factoids}; + + if ($factoids->get_data($channel, $trigger, 'locked')) { return "/say $trigger_name is locked; unlock before overwriting."; } + + my ($owner) = $factoids->get_data($channel, $trigger, 'owner') =~ m/([^!]+)/; + if ((lc $nick ne lc $owner) and (not $self->{pbot}->{users}->loggedin_admin($channel, "$nick!$user\@$host"))) { + return "You are not the owner of $trigger_name for $channel_name; cannot force overwrite."; + } + } } - # now this is the keyword - $keyword = $self->{pbot}->{interpreter}->shift_arg(\@arglist); - - # check for -url - if ($arglist[0] eq '-url') { - # discard it - $self->{pbot}->{interpreter}->shift_arg(\@arglist); - - # the URL is the remaining arguments - my ($url) = $self->{pbot}->{interpreter}->split_args(\@arglist, 1); - - # FIXME: move this to registry - if ($url !~ m/^https?:\/\/(?:sprunge.us|ix.io)\/\w+$/) { - return "Invalid URL: acceptable URLs are: http://sprunge.us, http://ix.io"; - } - - # create a UserAgent - my $ua = LWP::UserAgent->new(timeout => 10); - - # get the factoid's text from the URL - my $response = $ua->get($url); - - # process the response - if ($response->is_success) { - $text = $response->decoded_content; - } else { - return "Failed to get URL: " . $response->status_line; - } - } else { - # check for optional "is" and discard - if (lc $arglist[0] eq 'is') { - $self->{pbot}->{interpreter}->shift_arg(\@arglist); - } - - # and the text is the remaining arguments with quotes preserved - ($text) = $self->{pbot}->{interpreter}->split_args(\@arglist, 1, 0, 1); + ($channel, $trigger) = $self->{pbot}->{factoids}->find_factoid('.*', $keyword, exact_channel => 1, exact_trigger => 1); + if (defined $trigger and $self->{pbot}->{factoids}->{factoids}->get_data('.*', $trigger, 'nooverride')) { + my $trigger_name = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, '_name'); + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; + return "/say $trigger_name already exists for the global channel and cannot be overridden for " . ($from_chan eq '.*' ? 'the global channel' : $from_chan) . "."; } - } - if (not defined $from_chan or not defined $text or not defined $keyword) { - return "Usage: factadd [-f] [channel] ( | -url ); -f to force overwrite; -url to download from paste site"; - } + if ($self->{pbot}->{commands}->exists($keyword)) { return "/say $keyword_text already exists as a built-in command."; } - $from_chan = '.*' if $from_chan !~ /^#/; - - if (length $keyword > $self->{pbot}->{registry}->get_value('factoids', 'max_name_length')) { - return "/say $nick: I don't think the factoid name needs to be that long."; - } - - if (length $from_chan > $self->{pbot}->{registry}->get_value('factoids', 'max_channel_length')) { - return "/say $nick: I don't think the channel needs to be that long."; - } - - $from_chan = '.*' if lc $from_chan eq 'global'; - $from_chan = '.*' if not $from_chan =~ m/^#/; - - my $keyword_text = $keyword =~ / / ? "\"$keyword\"" : $keyword; - - my ($channel, $trigger) = $self->{pbot}->{factoids}->find_factoid($from_chan, $keyword, exact_channel => 1, exact_trigger => 1); - if (defined $trigger) { - 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' if $channel_name eq '.*'; - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - - if (not $force) { - return "/say $trigger_name already exists for $channel_name."; - } else { - my $factoids = $self->{pbot}->{factoids}->{factoids}; - - if ($factoids->get_data($channel, $trigger, 'locked')) { - return "/say $trigger_name is locked; unlock before overwriting."; - } - - my ($owner) = $factoids->get_data($channel, $trigger, 'owner') =~ m/([^!]+)/; - if ((lc $nick ne lc $owner) and (not $self->{pbot}->{users}->loggedin_admin($channel, "$nick!$user\@$host"))) { - return "You are not the owner of $trigger_name for $channel_name; cannot force overwrite."; - } - } - } - - ($channel, $trigger) = $self->{pbot}->{factoids}->find_factoid('.*', $keyword, exact_channel => 1, exact_trigger => 1); - if (defined $trigger and $self->{pbot}->{factoids}->{factoids}->get_data('.*', $trigger, 'nooverride')) { - my $trigger_name = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, '_name'); - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - return "/say $trigger_name already exists for the global channel and cannot be overridden for " . ($from_chan eq '.*' ? 'the global channel' : $from_chan) . "."; - } - - if ($self->{pbot}->{commands}->exists($keyword)) { - return "/say $keyword_text already exists as a built-in command."; - } - - $self->{pbot}->{factoids}->add_factoid('text', $from_chan, "$nick!$user\@$host", $keyword, $text); - $self->{pbot}->{logger}->log("$nick!$user\@$host added [$from_chan] $keyword_text => $text\n"); - return "/say $keyword_text added to " . ($from_chan eq '.*' ? 'global channel' : $from_chan) . "."; + $self->{pbot}->{factoids}->add_factoid('text', $from_chan, "$nick!$user\@$host", $keyword, $text); + $self->{pbot}->{logger}->log("$nick!$user\@$host added [$from_chan] $keyword_text => $text\n"); + return "/say $keyword_text added to " . ($from_chan eq '.*' ? 'global channel' : $from_chan) . "."; } sub factrem { - my $self = shift; - my ($from, $nick, $user, $host, $arguments, $stuff) = @_; - my $factoids = $self->{pbot}->{factoids}->{factoids}; + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $factoids = $self->{pbot}->{factoids}->{factoids}; - my ($from_chan, $from_trig) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); + my ($from_chan, $from_trig) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); - if (not defined $from_trig) { - $from_trig = $from_chan; - $from_chan = $from; - } + if (not defined $from_trig) { + $from_trig = $from_chan; + $from_chan = $from; + } - my ($channel, $trigger) = $self->find_factoid_with_optional_channel($from, $arguments, 'factrem', explicit => 1); - return $channel if not defined $trigger; # if $trigger is not defined, $channel is an error message + my ($channel, $trigger) = $self->find_factoid_with_optional_channel($from, $arguments, 'factrem', explicit => 1); + return $channel if not defined $trigger; # if $trigger is not defined, $channel is an error message - $channel = '.*' if $channel eq 'global'; - $from_chan = '.*' if $channel eq 'global'; + $channel = '.*' if $channel eq 'global'; + $from_chan = '.*' if $channel eq 'global'; - my $channel_name = $factoids->get_data($channel, '_name'); - my $trigger_name = $factoids->get_data($channel, $trigger, '_name'); - $channel_name = 'global' if $channel_name eq '.*'; - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; + my $channel_name = $factoids->get_data($channel, '_name'); + my $trigger_name = $factoids->get_data($channel, $trigger, '_name'); + $channel_name = 'global' if $channel_name eq '.*'; + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - if ($factoids->get_data($channel, $trigger, 'type') eq 'module') { - return "/say $trigger_name is not a factoid."; - } + if ($factoids->get_data($channel, $trigger, 'type') eq 'module') { return "/say $trigger_name is not a factoid."; } - if ($channel =~ /^#/ and $from_chan =~ /^#/ and $channel ne $from_chan) { - return "/say $trigger_name belongs to $channel_name, but this is $from_chan. Please switch to $channel_name or use /msg to remove this factoid."; - } + if ($channel =~ /^#/ and $from_chan =~ /^#/ and $channel ne $from_chan) { + return "/say $trigger_name belongs to $channel_name, but this is $from_chan. Please switch to $channel_name or use /msg to remove this factoid."; + } - my ($owner) = $factoids->get_data($channel, $trigger, 'owner') =~ m/([^!]+)/; + my ($owner) = $factoids->get_data($channel, $trigger, 'owner') =~ m/([^!]+)/; - if ((lc $nick ne lc $owner) and (not $self->{pbot}->{users}->loggedin_admin($channel, "$nick!$user\@$host"))) { - return "You are not the owner of $trigger_name for $channel_name."; - } + if ((lc $nick ne lc $owner) and (not $self->{pbot}->{users}->loggedin_admin($channel, "$nick!$user\@$host"))) { + return "You are not the owner of $trigger_name for $channel_name."; + } - if ($factoids->get_data($channel, $trigger, 'locked')) { - return "/say $trigger_name is locked; unlock before deleting."; - } + if ($factoids->get_data($channel, $trigger, 'locked')) { return "/say $trigger_name is locked; unlock before deleting."; } - $self->{pbot}->{logger}->log("$nick!$user\@$host removed [$channel][$trigger][" . $factoids->get_data($channel, $trigger, 'action') . "]\n"); - $self->{pbot}->{factoids}->remove_factoid($channel, $trigger); - $self->log_factoid($channel, $trigger, "$nick!$user\@$host", "deleted", 1); - return "/say $trigger_name removed from $channel_name."; + $self->{pbot}->{logger}->log("$nick!$user\@$host removed [$channel][$trigger][" . $factoids->get_data($channel, $trigger, 'action') . "]\n"); + $self->{pbot}->{factoids}->remove_factoid($channel, $trigger); + $self->log_factoid($channel, $trigger, "$nick!$user\@$host", "deleted", 1); + return "/say $trigger_name removed from $channel_name."; } sub histogram { - my $self = shift; - my ($from, $nick, $user, $host, $arguments) = @_; - my $factoids = $self->{pbot}->{factoids}->{factoids}; - my %hash; - my $factoid_count = 0; - foreach my $channel ($factoids->get_keys) { - foreach my $command ($factoids->get_keys($channel)) { - if ($factoids->get_data($channel, $command, 'type') eq 'text') { - $hash{$factoids->{$channel}->{$command}->{owner}}++; - $factoid_count++; - } + my $self = shift; + my ($from, $nick, $user, $host, $arguments) = @_; + my $factoids = $self->{pbot}->{factoids}->{factoids}; + my %hash; + my $factoid_count = 0; + + foreach my $channel ($factoids->get_keys) { + foreach my $command ($factoids->get_keys($channel)) { + if ($factoids->get_data($channel, $command, 'type') eq 'text') { + $hash{$factoids->{$channel}->{$command}->{owner}}++; + $factoid_count++; + } + } } - } - my $text; - my $i = 0; - foreach my $owner (sort {$hash{$b} <=> $hash{$a}} keys %hash) { - my $percent = int($hash{$owner} / $factoid_count * 100); - $text .= "$owner: $hash{$owner} ($percent". "%)\n"; - $i++; - last if $i >= 10; - } - return "/say $factoid_count factoids, top 10 submitters:\n$text"; + my $text; + my $i = 0; + foreach my $owner (sort { $hash{$b} <=> $hash{$a} } keys %hash) { + my $percent = int($hash{$owner} / $factoid_count * 100); + $text .= "$owner: $hash{$owner} ($percent" . "%)\n"; + $i++; + last if $i >= 10; + } + return "/say $factoid_count factoids, top 10 submitters:\n$text"; } sub factshow { - my $self = shift; - my ($from, $nick, $user, $host, $arguments, $stuff) = @_; - my $factoids = $self->{pbot}->{factoids}->{factoids}; - $stuff->{preserve_whitespace} = 1; - my $usage = "Usage: factshow [-p] [channel] ; -p to paste"; - return $usage if not $arguments; + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $factoids = $self->{pbot}->{factoids}->{factoids}; + $stuff->{preserve_whitespace} = 1; + my $usage = "Usage: factshow [-p] [channel] ; -p to paste"; + return $usage if not $arguments; - 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; + }; - my ($paste); - my ($ret, $args) = GetOptionsFromString($arguments, - 'p' => \$paste); + my ($paste); + my ($ret, $args) = GetOptionsFromString( + $arguments, + 'p' => \$paste + ); - return "/say $getopt_error -- $usage" if defined $getopt_error; - return "Too many arguments -- $usage" if @$args > 2; - return "Missing argument -- $usage" if not @$args; + return "/say $getopt_error -- $usage" if defined $getopt_error; + return "Too many arguments -- $usage" if @$args > 2; + return "Missing argument -- $usage" if not @$args; - my ($chan, $trig) = @$args; - $chan = $from if not defined $trig; - $args = join(' ', map { $_ = "'$_'" if $_ =~ m/ /; $_; } @$args); + my ($chan, $trig) = @$args; + $chan = $from if not defined $trig; + $args = join(' ', map { $_ = "'$_'" if $_ =~ m/ /; $_; } @$args); - my ($channel, $trigger) = $self->find_factoid_with_optional_channel($from, $args, 'factshow', usage => $usage); - return $channel if not defined $trigger; # if $trigger is not defined, $channel is an error message + my ($channel, $trigger) = $self->find_factoid_with_optional_channel($from, $args, 'factshow', usage => $usage); + return $channel if not defined $trigger; # if $trigger is not defined, $channel is an error message - my $channel_name = $factoids->get_data($channel, '_name'); - my $trigger_name = $factoids->get_data($channel, $trigger, '_name'); - $channel_name = 'global' if $channel_name eq '.*'; - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; + my $channel_name = $factoids->get_data($channel, '_name'); + my $trigger_name = $factoids->get_data($channel, $trigger, '_name'); + $channel_name = 'global' if $channel_name eq '.*'; + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - my $result = "$trigger_name: "; + my $result = "$trigger_name: "; - if ($paste) { - $result .= $self->{pbot}->{webpaste}->paste($factoids->get_data($channel, $trigger, 'action'), no_split => 1); + if ($paste) { + $result .= $self->{pbot}->{webpaste}->paste($factoids->get_data($channel, $trigger, 'action'), no_split => 1); + $result = "[$channel_name] $result" if $channel ne lc $chan; + return $result; + } + + $result .= $factoids->get_data($channel, $trigger, 'action'); + $result .= ' [module]' if $factoids->get_data($channel, $trigger, 'type') eq 'module'; $result = "[$channel_name] $result" if $channel ne lc $chan; return $result; - } - - $result .= $factoids->get_data($channel, $trigger, 'action'); - $result .= ' [module]' if $factoids->get_data($channel, $trigger, 'type') eq 'module'; - $result = "[$channel_name] $result" if $channel ne lc $chan; - return $result; } sub factlog { - my $self = shift; - my ($from, $nick, $user, $host, $arguments) = @_; + my $self = shift; + my ($from, $nick, $user, $host, $arguments) = @_; - my $usage = "Usage: factlog [-h] [-t] [channel] ; -h show full hostmask; -t show actual timestamp instead of relative"; + my $usage = "Usage: factlog [-h] [-t] [channel] ; -h show full hostmask; -t show actual timestamp instead of relative"; - return $usage if not $arguments; + return $usage if not $arguments; - my $getopt_error; - local $SIG{__WARN__} = sub { - $getopt_error = shift; - chomp $getopt_error; - }; - - my ($show_hostmask, $actual_timestamp); - my ($ret, $args) = GetOptionsFromString($arguments, - 'h' => \$show_hostmask, - 't' => \$actual_timestamp); - - return "/say $getopt_error -- $usage" if defined $getopt_error; - return "Too many arguments -- $usage" if @$args > 2; - return "Missing argument -- $usage" if not @$args; - - $args = join(' ', map { $_ = "'$_'" if $_ =~ m/ /; $_; } @$args); - - my ($channel, $trigger) = $self->find_factoid_with_optional_channel($from, $args, 'factlog', usage => $usage, exact_channel => 1); - - if (not defined $trigger) { - # factoid not found or some error, try to continue and load factlog file if it exists - my $arglist = $self->{pbot}->{interpreter}->make_args($args); - ($channel, $trigger) = $self->{pbot}->{interpreter}->split_args($arglist, 2); - if (not defined $trigger) { - $trigger = $channel; - $channel = $from; - } - $channel = '.*' if $channel !~ m/^#/; - } - - my $path = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/factlog'; - - $channel = 'global' if $channel eq '.*'; - - my $channel_safe = safe_filename $channel; - my $trigger_safe = safe_filename $trigger; - - open my $fh, "< $path/$trigger_safe.$channel_safe" or do { - $self->{pbot}->{logger}->log("Could not open $path/$trigger_safe.$channel_safe: $!\n"); - $channel = 'the global channel' if $channel eq 'global'; - return "No factlog available for $trigger in $channel."; - }; - - my @entries; - while (my $line = <$fh>) { - my ($timestamp, $hostmask, $msg); - - ($timestamp, $hostmask, $msg) = eval { - my $h = decode_json $line; - return ($h->{ts}, $h->{hm}, $h->{msg}); + my $getopt_error; + local $SIG{__WARN__} = sub { + $getopt_error = shift; + chomp $getopt_error; }; - ($timestamp, $hostmask, $msg) = split /\s+/, $line, 3 if $@; - $hostmask =~ s/!.*$// if not $show_hostmask; + my ($show_hostmask, $actual_timestamp); + my ($ret, $args) = GetOptionsFromString( + $arguments, + 'h' => \$show_hostmask, + 't' => \$actual_timestamp + ); - if ($actual_timestamp) { - $timestamp = strftime "%a %b %e %H:%M:%S %Z %Y", localtime $timestamp; - } else { - $timestamp = concise ago gettimeofday - $timestamp; + return "/say $getopt_error -- $usage" if defined $getopt_error; + return "Too many arguments -- $usage" if @$args > 2; + return "Missing argument -- $usage" if not @$args; + + $args = join(' ', map { $_ = "'$_'" if $_ =~ m/ /; $_; } @$args); + + my ($channel, $trigger) = $self->find_factoid_with_optional_channel($from, $args, 'factlog', usage => $usage, exact_channel => 1); + + if (not defined $trigger) { + + # factoid not found or some error, try to continue and load factlog file if it exists + my $arglist = $self->{pbot}->{interpreter}->make_args($args); + ($channel, $trigger) = $self->{pbot}->{interpreter}->split_args($arglist, 2); + if (not defined $trigger) { + $trigger = $channel; + $channel = $from; + } + $channel = '.*' if $channel !~ m/^#/; } - push @entries, "[$timestamp] $hostmask $msg\n"; - } - close $fh; - my $result = join "", reverse @entries; - return $result; + + my $path = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/factlog'; + + $channel = 'global' if $channel eq '.*'; + + my $channel_safe = safe_filename $channel; + my $trigger_safe = safe_filename $trigger; + + open my $fh, "< $path/$trigger_safe.$channel_safe" or do { + $self->{pbot}->{logger}->log("Could not open $path/$trigger_safe.$channel_safe: $!\n"); + $channel = 'the global channel' if $channel eq 'global'; + return "No factlog available for $trigger in $channel."; + }; + + my @entries; + while (my $line = <$fh>) { + my ($timestamp, $hostmask, $msg); + + ($timestamp, $hostmask, $msg) = eval { + my $h = decode_json $line; + return ($h->{ts}, $h->{hm}, $h->{msg}); + }; + + ($timestamp, $hostmask, $msg) = split /\s+/, $line, 3 if $@; + $hostmask =~ s/!.*$// if not $show_hostmask; + + if ($actual_timestamp) { $timestamp = strftime "%a %b %e %H:%M:%S %Z %Y", localtime $timestamp; } + else { $timestamp = concise ago gettimeofday - $timestamp; } + push @entries, "[$timestamp] $hostmask $msg\n"; + } + close $fh; + my $result = join "", reverse @entries; + return $result; } sub factinfo { - my $self = shift; - my ($from, $nick, $user, $host, $arguments, $stuff) = @_; - my $factoids = $self->{pbot}->{factoids}->{factoids}; - my ($chan, $trig) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $factoids = $self->{pbot}->{factoids}->{factoids}; + my ($chan, $trig) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); - if (not defined $trig) { - $trig = $chan; - $chan = $from; - } + if (not defined $trig) { + $trig = $chan; + $chan = $from; + } - my ($channel, $trigger) = $self->find_factoid_with_optional_channel($from, $arguments, 'factinfo'); - return $channel if not defined $trigger; # if $trigger is not defined, $channel is an error message + my ($channel, $trigger) = $self->find_factoid_with_optional_channel($from, $arguments, 'factinfo'); + return $channel if not defined $trigger; # if $trigger is not defined, $channel is an error message - my $channel_name = $factoids->get_data($channel, '_name'); - my $trigger_name = $factoids->get_data($channel, $trigger, '_name'); - $channel_name = 'global' if $channel_name eq '.*'; - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; + my $channel_name = $factoids->get_data($channel, '_name'); + my $trigger_name = $factoids->get_data($channel, $trigger, '_name'); + $channel_name = 'global' if $channel_name eq '.*'; + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - my $created_ago = ago(gettimeofday - $factoids->get_data($channel, $trigger, 'created_on')); - my $ref_ago = ago(gettimeofday - $factoids->get_data($channel, $trigger, 'last_referenced_on')) if defined $factoids->get_data($channel, $trigger, 'last_referenced_on'); + my $created_ago = ago(gettimeofday - $factoids->get_data($channel, $trigger, 'created_on')); + my $ref_ago = ago(gettimeofday - $factoids->get_data($channel, $trigger, 'last_referenced_on')) if defined $factoids->get_data($channel, $trigger, 'last_referenced_on'); - # factoid - if ($factoids->get_data($channel, $trigger, 'type') eq 'text') { - return "/say $trigger_name: Factoid submitted by " . $factoids->get_data($channel, $trigger, 'owner') . " for $channel_name on " . localtime($factoids->get_data($channel, $trigger, 'created_on')) . " [$created_ago], " . (defined $factoids->get_data($channel, $trigger, 'edited_by') ? 'last edited by ' . $factoids->get_data($channel, $trigger, 'edited_by') . ' on ' . localtime($factoids->get_data($channel, $trigger, 'edited_on')) . " [" . ago(gettimeofday - $factoids->get_data($channel, $trigger, 'edited_on')) . "], " : "") . "referenced " . $factoids->get_data($channel, $trigger, 'ref_count') . ' times (last by ' . $factoids->get_data($channel, $trigger, 'ref_user') . ($factoids->exists($channel, $trigger, 'last_referenced_on') ? ' on ' . localtime($factoids->get_data($channel, $trigger, 'last_referenced_on')) . " [$ref_ago]" : '') . ')'; - } + # factoid + if ($factoids->get_data($channel, $trigger, 'type') eq 'text') { + return + "/say $trigger_name: Factoid submitted by " + . $factoids->get_data($channel, $trigger, 'owner') + . " for $channel_name on " + . localtime($factoids->get_data($channel, $trigger, 'created_on')) + . " [$created_ago], " + . ( + defined $factoids->get_data($channel, $trigger, 'edited_by') + ? 'last edited by ' + . $factoids->get_data($channel, $trigger, 'edited_by') . ' on ' + . localtime($factoids->get_data($channel, $trigger, 'edited_on')) . " [" + . ago(gettimeofday - $factoids->get_data($channel, $trigger, 'edited_on')) . "], " + : "" + ) + . "referenced " + . $factoids->get_data($channel, $trigger, 'ref_count') + . ' times (last by ' + . $factoids->get_data($channel, $trigger, 'ref_user') + . ($factoids->exists($channel, $trigger, 'last_referenced_on') ? ' on ' . localtime($factoids->get_data($channel, $trigger, 'last_referenced_on')) . " [$ref_ago]" : '') + . ')'; + } - # module - if ($factoids->get_data($channel, $trigger, 'type') eq 'module') { - my $module_repo = $self->{pbot}->{registry}->get_value('general', 'module_repo'); - $module_repo .= $factoids->get_data($channel, $trigger, 'workdir'). '/' if $factoids->exists($channel, $trigger, 'workdir'); - return "/say $trigger_name: Module loaded by " . $factoids->get_data($channel, $trigger, 'owner') . " for $channel_name on " . localtime($factoids->get_data($channel, $trigger, 'created_on')) . " [$created_ago] -> $module_repo" . $factoids->get_data($channel, $trigger, 'action') . ', used ' . $factoids->get_data($channel, $trigger, 'ref_count') . ' times (last by ' . $factoids->get_data($channel, $trigger, 'ref_user') . ($factoids->exists($channel, $trigger, 'last_referenced_on') ? ' on ' . localtime($factoids->get_data($channel, $trigger, 'last_referenced_on')) . " [$ref_ago]" : '') . ')'; - } + # module + if ($factoids->get_data($channel, $trigger, 'type') eq 'module') { + my $module_repo = $self->{pbot}->{registry}->get_value('general', 'module_repo'); + $module_repo .= $factoids->get_data($channel, $trigger, 'workdir') . '/' if $factoids->exists($channel, $trigger, 'workdir'); + return + "/say $trigger_name: Module loaded by " + . $factoids->get_data($channel, $trigger, 'owner') + . " for $channel_name on " + . localtime($factoids->get_data($channel, $trigger, 'created_on')) + . " [$created_ago] -> $module_repo" + . $factoids->get_data($channel, $trigger, 'action') + . ', used ' + . $factoids->get_data($channel, $trigger, 'ref_count') + . ' times (last by ' + . $factoids->get_data($channel, $trigger, 'ref_user') + . ($factoids->exists($channel, $trigger, 'last_referenced_on') ? ' on ' . localtime($factoids->get_data($channel, $trigger, 'last_referenced_on')) . " [$ref_ago]" : '') + . ')'; + } - # regex - if ($factoids->get_data($channel, $trigger, 'type') eq 'regex') { - return "/say $trigger_name: Regex created by " . $factoids->get_data($channel, $trigger, 'owner') . " for $channel_name on " . localtime($factoids->get_data($channel, $trigger, 'created_on')) . " [$created_ago], " . (defined $factoids->get_data($channel, $trigger, 'edited_by') ? 'last edited by ' . $factoids->get_data($channel, $trigger, 'edited_by') . ' on ' . localtime($factoids->get_data($channel, $trigger, 'edited_on')) . " [" . ago(gettimeofday - $factoids->get_data($channel, $trigger, 'edited_on')) . "], " : "") . ' used ' . $factoids->get_data($channel, $trigger, 'ref_count') . ' times (last by ' . $factoids->get_data($channel, $trigger, 'ref_user') . ($factoids->exists($channel, $trigger, 'last_referenced_on') ? ' on ' . localtime($factoids->get_data($channel, $trigger, 'last_referenced_on')) . " [$ref_ago]" : '') . ')'; - } + # regex + if ($factoids->get_data($channel, $trigger, 'type') eq 'regex') { + return + "/say $trigger_name: Regex created by " + . $factoids->get_data($channel, $trigger, 'owner') + . " for $channel_name on " + . localtime($factoids->get_data($channel, $trigger, 'created_on')) + . " [$created_ago], " + . ( + defined $factoids->get_data($channel, $trigger, 'edited_by') + ? 'last edited by ' + . $factoids->get_data($channel, $trigger, 'edited_by') . ' on ' + . localtime($factoids->get_data($channel, $trigger, 'edited_on')) . " [" + . ago(gettimeofday - $factoids->get_data($channel, $trigger, 'edited_on')) . "], " + : "" + ) + . ' used ' + . $factoids->get_data($channel, $trigger, 'ref_count') + . ' times (last by ' + . $factoids->get_data($channel, $trigger, 'ref_user') + . ($factoids->exists($channel, $trigger, 'last_referenced_on') ? ' on ' . localtime($factoids->get_data($channel, $trigger, 'last_referenced_on')) . " [$ref_ago]" : '') + . ')'; + } - return "/say $arguments is not a factoid or a module."; + return "/say $arguments is not a factoid or a module."; } sub top20 { - my $self = shift; - my ($from, $nick, $user, $host, $arguments, $stuff) = @_; - my $factoids = $self->{pbot}->{factoids}->{factoids}; - my %hash = (); - my $text = ""; - my $i = 0; - my ($channel, $args) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); + my $self = shift; - if (not defined $channel) { - return "Usage: top20 [nick or 'recent']"; - } + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $factoids = $self->{pbot}->{factoids}->{factoids}; + my %hash = (); + my $text = ""; + my $i = 0; - if (not defined $args) { - foreach my $chan (sort $factoids->get_keys) { - next if lc $chan ne lc $channel; - foreach my $command (sort {$factoids->get_data($chan, $b, 'ref_count') <=> $factoids->get_data($chan, $a, 'ref_count')} $factoids->get_keys($chan)) { - if ($factoids->get_data($chan, $command, 'ref_count') > 0 and $factoids->get_data($chan, $command, 'type') eq 'text') { - $text .= $factoids->get_data($chan, $command, '_name') . ' (' . $factoids->get_data($chan, $command, 'ref_count') . ') '; - $i++; - last if $i >= 20; + my ($channel, $args) = $self->{pbot}->{interpreter}->split_args($stuff->{arglist}, 2); + + if (not defined $channel) { return "Usage: top20 [nick or 'recent']"; } + + if (not defined $args) { + foreach my $chan (sort $factoids->get_keys) { + next if lc $chan ne lc $channel; + foreach my $command (sort { $factoids->get_data($chan, $b, 'ref_count') <=> $factoids->get_data($chan, $a, 'ref_count') } $factoids->get_keys($chan)) { + if ($factoids->get_data($chan, $command, 'ref_count') > 0 and $factoids->get_data($chan, $command, 'type') eq 'text') { + $text .= $factoids->get_data($chan, $command, '_name') . ' (' . $factoids->get_data($chan, $command, 'ref_count') . ') '; + $i++; + last if $i >= 20; + } + } + $channel = "the global channel" if $channel eq '.*'; + $text = "Top $i referenced factoids for $channel: $text" if $i > 0; + return $text; } - } - $channel = "the global channel" if $channel eq '.*'; - $text = "Top $i referenced factoids for $channel: $text" if $i > 0; - return $text; - } - } else { - if (lc $args eq "recent") { - foreach my $chan (sort $factoids->get_keys) { - next if lc $chan ne lc $channel; - foreach my $command (sort { $factoids->get_data($chan, $b, 'created_on') <=> $factoids->get_data($chan, $a, 'created_on') } $factoids->get_keys($chan)) { - my $ago = concise ago gettimeofday - $factoids->get_data($chan, $command, 'created_on'); - my $owner = $factoids->get_data($chan, $command, 'owner'); - $owner =~ s/!.*$//; - $text .= ' ' . $factoids->get_data($chan, $command, '_name') . " [$ago by $owner]\n"; - $i++; - last if $i >= 50; + } else { + if (lc $args eq "recent") { + foreach my $chan (sort $factoids->get_keys) { + next if lc $chan ne lc $channel; + foreach my $command (sort { $factoids->get_data($chan, $b, 'created_on') <=> $factoids->get_data($chan, $a, 'created_on') } $factoids->get_keys($chan)) { + my $ago = concise ago gettimeofday - $factoids->get_data($chan, $command, 'created_on'); + my $owner = $factoids->get_data($chan, $command, 'owner'); + $owner =~ s/!.*$//; + $text .= ' ' . $factoids->get_data($chan, $command, '_name') . " [$ago by $owner]\n"; + $i++; + last if $i >= 50; + } + $channel = "global channel" if $channel eq '.*'; + $text = "$i most recent $channel submissions:\n\n$text" if $i > 0; + return $text; + } } - $channel = "global channel" if $channel eq '.*'; - $text = "$i most recent $channel submissions:\n\n$text" if $i > 0; - return $text; - } - } - my $user = lc $args; - foreach my $chan (sort $factoids->get_keys) { - next if lc $chan ne lc $channel; - foreach my $command (sort { ($factoids->get_data($chan, $b, 'last_referenced_on') || 0) <=> ($factoids->get_data($chan, $a, 'last_referenced_on') || 0) } $factoids->get_keys($chan)) { - next if $command eq '_name'; - my $ref_user = lc $factoids->get_data($chan, $command, 'ref_user'); - if ($ref_user =~ /\Q$args\E/i) { - if ($user ne $ref_user && not $user =~ /$ref_user/i) { - $user .= " ($ref_user)"; - } - my $ago = $factoids->get_data($chan, $command, 'last_referenced_on') ? concise ago(gettimeofday - $factoids->get_data($chan, $command, 'last_referenced_on')) : "unknown"; - $text .= ' ' . $factoids->get_data($chan, $command, '_name') . " [$ago]\n"; - $i++; - last if $i >= 20; + my $user = lc $args; + foreach my $chan (sort $factoids->get_keys) { + next if lc $chan ne lc $channel; + foreach my $command (sort { ($factoids->get_data($chan, $b, 'last_referenced_on') || 0) <=> ($factoids->get_data($chan, $a, 'last_referenced_on') || 0) } + $factoids->get_keys($chan)) + { + next if $command eq '_name'; + my $ref_user = lc $factoids->get_data($chan, $command, 'ref_user'); + if ($ref_user =~ /\Q$args\E/i) { + if ($user ne $ref_user && not $user =~ /$ref_user/i) { $user .= " ($ref_user)"; } + my $ago = $factoids->get_data($chan, $command, 'last_referenced_on') ? concise ago(gettimeofday - $factoids->get_data($chan, $command, 'last_referenced_on')) : "unknown"; + $text .= ' ' . $factoids->get_data($chan, $command, '_name') . " [$ago]\n"; + $i++; + last if $i >= 20; + } + } + $text = "$i factoids last referenced by $user:\n\n$text" if $i > 0; + return $text; } - } - $text = "$i factoids last referenced by $user:\n\n$text" if $i > 0; - return $text; } - } } sub count { - my $self = shift; - my ($from, $nick, $user, $host, $arguments) = @_; - my $factoids = $self->{pbot}->{factoids}->{factoids}; - my $i = 0; - my $total = 0; - if (not length $arguments) { - return "Usage: count "; - } + my $self = shift; + my ($from, $nick, $user, $host, $arguments) = @_; + my $factoids = $self->{pbot}->{factoids}->{factoids}; + my $i = 0; + my $total = 0; - $arguments = ".*" if ($arguments =~ /^factoids$/); + if (not length $arguments) { return "Usage: count "; } - eval { - foreach my $channel ($factoids->get_keys) { - foreach my $command ($factoids->get_keys($channel)) { - next if $command eq '_name'; - next if $factoids->get_data($channel, $command, 'type') ne 'text'; - $total++; - if ($factoids->get_data($channel, $command, 'owner') =~ /^\Q$arguments\E$/i) { - $i++; + $arguments = ".*" if ($arguments =~ /^factoids$/); + + eval { + foreach my $channel ($factoids->get_keys) { + foreach my $command ($factoids->get_keys($channel)) { + next if $command eq '_name'; + next if $factoids->get_data($channel, $command, 'type') ne 'text'; + $total++; + if ($factoids->get_data($channel, $command, 'owner') =~ /^\Q$arguments\E$/i) { $i++; } + } } - } + }; + return "/msg $nick $arguments: $@" if $@; + + return "I have $i factoids." if $arguments eq ".*"; + + if ($i > 0) { + my $percent = int($i / $total * 100); + $percent = 1 if $percent == 0; + return "/say $arguments has submitted $i factoids out of $total ($percent" . "%)"; + } else { + return "/say $arguments hasn't submitted any factoids"; } - }; - return "/msg $nick $arguments: $@" if $@; - - return "I have $i factoids." if $arguments eq ".*"; - - if ($i > 0) { - my $percent = int($i / $total * 100); - $percent = 1 if $percent == 0; - return "/say $arguments has submitted $i factoids out of $total ($percent"."%)"; - } else { - return "/say $arguments hasn't submitted any factoids"; - } } sub factfind { - my $self = shift; - my ($from, $nick, $user, $host, $arguments) = @_; + my $self = shift; + my ($from, $nick, $user, $host, $arguments) = @_; - my $usage = "Usage: factfind [-channel channel] [-owner regex] [-editby regex] [-refby regex] [-regex] [text]"; - return $usage if not defined $arguments; + my $usage = "Usage: factfind [-channel channel] [-owner regex] [-editby regex] [-refby regex] [-regex] [text]"; + return $usage if not defined $arguments; - my $factoids = $self->{pbot}->{factoids}->{factoids}; - my ($channel, $owner, $refby, $editby, $use_regex); - $channel = $1 if $arguments =~ s/\s*-channel\s+([^\b\s]+)//i; - $owner = $1 if $arguments =~ s/\s*-owner\s+([^\b\s]+)//i; - $refby = $1 if $arguments =~ s/\s*-refby\s+([^\b\s]+)//i; - $editby = $1 if $arguments =~ s/\s*-editby\s+([^\b\s]+)//i; - $use_regex = 1 if $arguments =~ s/\s*-regex\b//i; + my $factoids = $self->{pbot}->{factoids}->{factoids}; + my ($channel, $owner, $refby, $editby, $use_regex); + $channel = $1 if $arguments =~ s/\s*-channel\s+([^\b\s]+)//i; + $owner = $1 if $arguments =~ s/\s*-owner\s+([^\b\s]+)//i; + $refby = $1 if $arguments =~ s/\s*-refby\s+([^\b\s]+)//i; + $editby = $1 if $arguments =~ s/\s*-editby\s+([^\b\s]+)//i; + $use_regex = 1 if $arguments =~ s/\s*-regex\b//i; - $owner = '.*' if not defined $owner; - $refby = '.*' if not defined $refby; - $editby = '.*' if not defined $editby; + $owner = '.*' if not defined $owner; + $refby = '.*' if not defined $refby; + $editby = '.*' if not defined $editby; - $arguments =~ s/^\s+//; - $arguments =~ s/\s+$//; - $arguments =~ s/\s+/ /g; + $arguments =~ s/^\s+//; + $arguments =~ s/\s+$//; + $arguments =~ s/\s+/ /g; - $arguments = substr($arguments, 0, 30); - my $argtype = undef; + $arguments = substr($arguments, 0, 30); + my $argtype = undef; - $argtype = "owned by $owner" if $owner ne '.*'; + $argtype = "owned by $owner" if $owner ne '.*'; - if ($refby ne '.*') { - if (not defined $argtype) { - $argtype = "last referenced by $refby"; - } else { - $argtype .= " and last referenced by $refby"; - } - } - - if ($editby ne '.*') { - if (not defined $argtype) { - $argtype = "last edited by $editby"; - } else { - $argtype .= " and last edited by $editby"; - } - } - - if ($arguments ne "") { - my $unquoted_args = $arguments; - $unquoted_args =~ s/(?:\\(?!\\))//g; - $unquoted_args =~ s/(?:\\\\)/\\/g; - if (not defined $argtype) { - $argtype = "with text containing '$unquoted_args'"; - } else { - $argtype .= " and with text containing '$unquoted_args'"; - } - } - - if (not defined $argtype) { - return $usage; - } - - my ($text, $last_trigger, $last_chan, $i); - $last_chan = ""; - $i = 0; - eval { - use re::engine::RE2 -strict => 1; - my $regex; - if ($use_regex) { - $regex = $arguments; - } else { - $regex = ($arguments =~ m/^\w/) ? '\b' : '\B'; - $regex .= quotemeta $arguments; - $regex .= ($arguments =~ m/\w$/) ? '\b' : '\B'; + if ($refby ne '.*') { + if (not defined $argtype) { $argtype = "last referenced by $refby"; } + else { $argtype .= " and last referenced by $refby"; } } - foreach my $chan (sort $factoids->get_keys) { - next if defined $channel and $chan !~ /^$channel$/i; - foreach my $trigger (sort $factoids->get_keys($chan)) { - next if $trigger eq '_name'; - if ($factoids->get_data($chan, $trigger, 'type') eq 'text' or $factoids->get_data($chan, $trigger, 'type') eq 'regex') { - if ($factoids->get_data($chan, $trigger, 'owner') =~ /^$owner$/i - && $factoids->get_data($chan, $trigger, 'ref_user') =~ /^$refby$/i - && ($factoids->exists($chan, $trigger, 'edited_by') ? $factoids->get_data($chan, $trigger, 'edited_by') =~ /^$editby$/i : 1)) { - next if ($arguments ne "" && $factoids->get_data($chan, $trigger, 'action') !~ /$regex/i && $trigger !~ /$regex/i); - $i++; - if ($chan ne $last_chan) { - $text .= $chan eq '.*' ? '[global channel] ' : '[' . $factoids->get_data($chan, '_name') . '] '; - $last_chan = $chan; - } - my $trigger_name = $factoids->get_data($chan, $trigger, '_name'); - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - $text .= "$trigger_name "; - $last_trigger = $trigger_name; - } + if ($editby ne '.*') { + if (not defined $argtype) { $argtype = "last edited by $editby"; } + else { $argtype .= " and last edited by $editby"; } + } + + if ($arguments ne "") { + my $unquoted_args = $arguments; + $unquoted_args =~ s/(?:\\(?!\\))//g; + $unquoted_args =~ s/(?:\\\\)/\\/g; + if (not defined $argtype) { $argtype = "with text containing '$unquoted_args'"; } + else { $argtype .= " and with text containing '$unquoted_args'"; } + } + + if (not defined $argtype) { return $usage; } + + my ($text, $last_trigger, $last_chan, $i); + $last_chan = ""; + $i = 0; + eval { + use re::engine::RE2 -strict => 1; + my $regex; + if ($use_regex) { $regex = $arguments; } + else { + $regex = ($arguments =~ m/^\w/) ? '\b' : '\B'; + $regex .= quotemeta $arguments; + $regex .= ($arguments =~ m/\w$/) ? '\b' : '\B'; } - } + + foreach my $chan (sort $factoids->get_keys) { + next if defined $channel and $chan !~ /^$channel$/i; + foreach my $trigger (sort $factoids->get_keys($chan)) { + next if $trigger eq '_name'; + if ($factoids->get_data($chan, $trigger, 'type') eq 'text' or $factoids->get_data($chan, $trigger, 'type') eq 'regex') { + if ( $factoids->get_data($chan, $trigger, 'owner') =~ /^$owner$/i + && $factoids->get_data($chan, $trigger, 'ref_user') =~ /^$refby$/i + && ($factoids->exists($chan, $trigger, 'edited_by') ? $factoids->get_data($chan, $trigger, 'edited_by') =~ /^$editby$/i : 1)) + { + next if ($arguments ne "" && $factoids->get_data($chan, $trigger, 'action') !~ /$regex/i && $trigger !~ /$regex/i); + $i++; + if ($chan ne $last_chan) { + $text .= $chan eq '.*' ? '[global channel] ' : '[' . $factoids->get_data($chan, '_name') . '] '; + $last_chan = $chan; + } + my $trigger_name = $factoids->get_data($chan, $trigger, '_name'); + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; + $text .= "$trigger_name "; + $last_trigger = $trigger_name; + } + } + } + } + }; + + return "/msg $nick $arguments: $@" if $@; + + if ($i == 1) { + chop $text; + return + "Found one factoid submitted for " + . ($last_chan eq '.*' ? 'global channel' : $factoids->get_data($last_chan, '_name')) . ' ' + . $argtype + . ": $last_trigger is " + . $factoids->get_data($last_chan, $last_trigger, 'action'); + } else { + return "Found $i factoids " . $argtype . ": $text" unless $i == 0; + my $chans = (defined $channel ? ($channel eq '.*' ? 'global channel' : $channel) : 'any channels'); + return "No factoids " . $argtype . " submitted for $chans."; } - }; - - return "/msg $nick $arguments: $@" if $@; - - if ($i == 1) { - chop $text; - return "Found one factoid submitted for " . ($last_chan eq '.*' ? 'global channel' : $factoids->get_data($last_chan, '_name')) . ' ' . $argtype . ": $last_trigger is " . $factoids->get_data($last_chan, $last_trigger, 'action'); - } else { - return "Found $i factoids " . $argtype . ": $text" unless $i == 0; - my $chans = (defined $channel ? ($channel eq '.*' ? 'global channel' : $channel) : 'any channels'); - return "No factoids " . $argtype . " submitted for $chans."; - } } sub factchange { - my $self = shift; - my ($from, $nick, $user, $host, $arguments, $stuff) = @_; - my $factoids_data = $self->{pbot}->{factoids}->{factoids}; - my ($channel, $trigger, $keyword, $delim, $tochange, $changeto, $modifier, $url); + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $factoids_data = $self->{pbot}->{factoids}->{factoids}; + my ($channel, $trigger, $keyword, $delim, $tochange, $changeto, $modifier, $url); - $stuff->{preserve_whitespace} = 1; + $stuff->{preserve_whitespace} = 1; - my $needs_disambig; + my $needs_disambig; - if (length $arguments) { - my $args = $stuff->{arglist}; - my $sub; + if (length $arguments) { + my $args = $stuff->{arglist}; + my $sub; - my $arg_count = $self->{pbot}->{interpreter}->arglist_size($args); + my $arg_count = $self->{pbot}->{interpreter}->arglist_size($args); - if ($arg_count >= 4 and ($args->[0] =~ m/^#/ or $args->[0] eq '.*' or lc $args->[0] eq 'global') and ($args->[2] eq '-url')) { - $channel = $args->[0]; - $keyword = $args->[1]; - $url = $args->[3]; - $needs_disambig = 0; - } elsif ($arg_count >= 3 and $args->[1] eq '-url') { - $keyword = $args->[0]; - $url = $args->[2]; - $channel = $from; - $needs_disambig = 1; - } elsif ($arg_count >= 3 and ($args->[0] =~ m/^#/ or $args->[0] eq '.*' or lc $args->[0] eq 'global') and ($args->[2] =~ m/^s([[:punct:]])/)) { - $delim = $1; - $channel = $args->[0]; - $keyword = $args->[1]; - ($sub) = $self->{pbot}->{interpreter}->split_args($args, 1, 2, 1); - $needs_disambig = 0; - } elsif ($arg_count >= 2 and $args->[1] =~ m/^s([[:punct:]])/) { - $delim = $1; - $keyword = $args->[0]; - $channel = $from; - ($sub) = $self->{pbot}->{interpreter}->split_args($args, 1, 1, 1); - $needs_disambig = 1; - } - - if (defined $sub) { - $delim = quotemeta $delim; - - if ($sub =~ /^s$delim(.*?)$delim(.*)$delim(.*)$/) { - $tochange = $1; - $changeto = $2; - $modifier = $3; - } elsif ($sub =~ /^s$delim(.*?)$delim(.*)$/) { - $tochange = $1; - $changeto = $2; - $modifier = ''; - } - } - } - - if (not defined $channel or (not defined $changeto and not defined $url)) { - return "Usage: factchange [channel] (s/// | -url )"; - } - - my ($from_trigger, $from_chan) = ($keyword, $channel); - my @factoids = $self->{pbot}->{factoids}->find_factoid($from_chan, $keyword, exact_trigger => 1); - - if (not @factoids or not $factoids[0]) { - $from_chan = 'global channel' if $from_chan eq '.*'; - return "/say $keyword not found in $from_chan"; - } - - if (@factoids > 1) { - if (not grep { $_->[0] eq $from_chan } @factoids) { - return "/say $from_trigger found in multiple channels: " . (join ', ', sort map { $_->[0] eq '.*' ? 'global' : $_->[0] } @factoids) . "; use `factchange $from_trigger` to disambiguate."; - } else { - foreach my $factoid (@factoids) { - if ($factoid->[0] eq $from_chan) { - ($channel, $trigger) = ($factoid->[0], $factoid->[1]); - last; + if ($arg_count >= 4 and ($args->[0] =~ m/^#/ or $args->[0] eq '.*' or lc $args->[0] eq 'global') and ($args->[2] eq '-url')) { + $channel = $args->[0]; + $keyword = $args->[1]; + $url = $args->[3]; + $needs_disambig = 0; + } elsif ($arg_count >= 3 and $args->[1] eq '-url') { + $keyword = $args->[0]; + $url = $args->[2]; + $channel = $from; + $needs_disambig = 1; + } elsif ($arg_count >= 3 and ($args->[0] =~ m/^#/ or $args->[0] eq '.*' or lc $args->[0] eq 'global') and ($args->[2] =~ m/^s([[:punct:]])/)) { + $delim = $1; + $channel = $args->[0]; + $keyword = $args->[1]; + ($sub) = $self->{pbot}->{interpreter}->split_args($args, 1, 2, 1); + $needs_disambig = 0; + } elsif ($arg_count >= 2 and $args->[1] =~ m/^s([[:punct:]])/) { + $delim = $1; + $keyword = $args->[0]; + $channel = $from; + ($sub) = $self->{pbot}->{interpreter}->split_args($args, 1, 1, 1); + $needs_disambig = 1; } - } - } - } else { - ($channel, $trigger) = ($factoids[0]->[0], $factoids[0]->[1]); - } - if (not defined $trigger) { - return "/say $keyword not found in channel $from_chan."; - } + if (defined $sub) { + $delim = quotemeta $delim; - 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' if $channel_name eq '.*'; - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - - $from_chan = '.*' if $from_chan eq 'global'; - - if ($channel =~ /^#/ and $from_chan =~ /^#/ and $channel ne $from_chan) { - return "/say $trigger_name belongs to $channel_name, but this is $from_chan. Please switch to $channel_name or use /msg to change this factoid."; - } - - my $userinfo = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); - if ($factoids_data->get_data($channel, $trigger, 'locked')) { - return "/say $trigger_name is locked and cannot be changed." if not $self->{pbot}->{capabilities}->userhas($userinfo, 'admin'); - - if ($factoids_data->exists($channel, $trigger, 'cap-override') and not $self->{pbot}->{capabilities}->userhas($userinfo, 'botowner')) { - return "/say $trigger_name is locked with a cap-override set and cannot be changed until the override is removed."; - } - } - - my $action = $factoids_data->get_data($channel, $trigger, 'action'); - - if (defined $url) { - # FIXME: move this to registry - if ($url !~ m/^https?:\/\/(?:sprunge.us|ix.io)\/\w+$/) { - return "Invalid URL: acceptable URLs are: http://sprunge.us, http://ix.io"; - } - - my $ua = LWP::UserAgent->new(timeout => 10); - my $response = $ua->get($url); - - if ($response->is_success) { - $action = $response->decoded_content; - } else { - return "Failed to get URL: " . $response->status_line; - } - } else { - my $ret = eval { - use re::engine::RE2 -strict => 1; - my $changed; - - if ($modifier eq 'gi' or $modifier eq 'ig' or $modifier eq 'g') { - my @chars = ("A".."Z", "a".."z", "0".."9"); - my $magic = ''; - $magic .= $chars[rand @chars] for 1..(10 * rand) + 10; - my $insensitive = index ($modifier, 'i') + 1; - my $count = 0; - my $max = 50; - - while (1) { - if ($count == 0) { - if ($insensitive) { - $changed = $action =~ s|$tochange|$changeto$magic|i; - } else { - $changed = $action =~ s|$tochange|$changeto$magic|; + if ($sub =~ /^s$delim(.*?)$delim(.*)$delim(.*)$/) { + $tochange = $1; + $changeto = $2; + $modifier = $3; + } elsif ($sub =~ /^s$delim(.*?)$delim(.*)$/) { + $tochange = $1; + $changeto = $2; + $modifier = ''; } - } else { - if ($insensitive) { - $changed = $action =~ s|$tochange|$1$changeto$magic|i; - } else { - $changed = $action =~ s|$tochange|$1$changeto$magic|; - } - } - - if ($changed) { - $count++; - if ($count == $max) { - $action =~ s/$magic//; - last; - } - $tochange = "$magic(.*?)$tochange" if $count == 1; - } else { - $changed = $count; - $action =~ s/$magic// if $changed; - last; - } } - } elsif ($modifier eq 'i') { - $changed = $action =~ s|$tochange|$changeto|i; - } else { - $changed = $action =~ s|$tochange|$changeto|; - } - - if (not $changed) { - $self->{pbot}->{logger}->log("($from) $nick!$user\@$host: failed to change '$trigger' 's$delim$tochange$delim$changeto$delim\n"); - return "Change $trigger failed."; - } - return ""; - }; - - if ($@) { - my $err = $@; - $err =~ s/ at PBot\/FactoidCommand.*$//; - return "/msg $nick Change $trigger_name failed: $err"; } - return $ret if length $ret; - } - if (length $action > 8000 and not $self->{pbot}->{capabilities}->userhas($userinfo, 'admin')) { - return "Change $trigger_name failed; result is too long."; - } + if (not defined $channel or (not defined $changeto and not defined $url)) { + return "Usage: factchange [channel] (s/// | -url )"; + } - if (not length $action) { - return "Change $trigger_name failed; factoids cannot be empty."; - } + my ($from_trigger, $from_chan) = ($keyword, $channel); + my @factoids = $self->{pbot}->{factoids}->find_factoid($from_chan, $keyword, exact_trigger => 1); - $self->{pbot}->{logger}->log("($from) $nick!$user\@$host: changed '$trigger' 's/$tochange/$changeto/\n"); + if (not @factoids or not $factoids[0]) { + $from_chan = 'global channel' if $from_chan eq '.*'; + return "/say $keyword not found in $from_chan"; + } - $factoids_data->set($channel, $trigger, 'action', $action, 1); - $factoids_data->set($channel, $trigger, 'edited_by', "$nick!$user\@$host", 1); - $factoids_data->set($channel, $trigger, 'edited_on', gettimeofday); - $self->log_factoid($channel, $trigger, "$nick!$user\@$host", "changed to $action"); - return "Changed: $trigger_name is $action"; + if (@factoids > 1) { + if (not grep { $_->[0] eq $from_chan } @factoids) { + return + "/say $from_trigger found in multiple channels: " + . (join ', ', sort map { $_->[0] eq '.*' ? 'global' : $_->[0] } @factoids) + . "; use `factchange $from_trigger` to disambiguate."; + } else { + foreach my $factoid (@factoids) { + if ($factoid->[0] eq $from_chan) { + ($channel, $trigger) = ($factoid->[0], $factoid->[1]); + last; + } + } + } + } else { + ($channel, $trigger) = ($factoids[0]->[0], $factoids[0]->[1]); + } + + if (not defined $trigger) { return "/say $keyword not found in channel $from_chan."; } + + 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' if $channel_name eq '.*'; + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; + + $from_chan = '.*' if $from_chan eq 'global'; + + if ($channel =~ /^#/ and $from_chan =~ /^#/ and $channel ne $from_chan) { + return "/say $trigger_name belongs to $channel_name, but this is $from_chan. Please switch to $channel_name or use /msg to change this factoid."; + } + + my $userinfo = $self->{pbot}->{users}->loggedin($channel, "$nick!$user\@$host"); + if ($factoids_data->get_data($channel, $trigger, 'locked')) { + return "/say $trigger_name is locked and cannot be changed." if not $self->{pbot}->{capabilities}->userhas($userinfo, 'admin'); + + if ($factoids_data->exists($channel, $trigger, 'cap-override') and not $self->{pbot}->{capabilities}->userhas($userinfo, 'botowner')) { + return "/say $trigger_name is locked with a cap-override set and cannot be changed until the override is removed."; + } + } + + my $action = $factoids_data->get_data($channel, $trigger, 'action'); + + if (defined $url) { + + # FIXME: move this to registry + if ($url !~ m/^https?:\/\/(?:sprunge.us|ix.io)\/\w+$/) { return "Invalid URL: acceptable URLs are: http://sprunge.us, http://ix.io"; } + + my $ua = LWP::UserAgent->new(timeout => 10); + my $response = $ua->get($url); + + if ($response->is_success) { $action = $response->decoded_content; } + else { return "Failed to get URL: " . $response->status_line; } + } else { + my $ret = eval { + use re::engine::RE2 -strict => 1; + my $changed; + + if ($modifier eq 'gi' or $modifier eq 'ig' or $modifier eq 'g') { + my @chars = ("A" .. "Z", "a" .. "z", "0" .. "9"); + my $magic = ''; + $magic .= $chars[rand @chars] for 1 .. (10 * rand) + 10; + my $insensitive = index($modifier, 'i') + 1; + my $count = 0; + my $max = 50; + + while (1) { + if ($count == 0) { + if ($insensitive) { $changed = $action =~ s|$tochange|$changeto$magic|i; } + else { $changed = $action =~ s|$tochange|$changeto$magic|; } + } else { + if ($insensitive) { $changed = $action =~ s|$tochange|$1$changeto$magic|i; } + else { $changed = $action =~ s|$tochange|$1$changeto$magic|; } + } + + if ($changed) { + $count++; + if ($count == $max) { + $action =~ s/$magic//; + last; + } + $tochange = "$magic(.*?)$tochange" if $count == 1; + } else { + $changed = $count; + $action =~ s/$magic// if $changed; + last; + } + } + } elsif ($modifier eq 'i') { + $changed = $action =~ s|$tochange|$changeto|i; + } else { + $changed = $action =~ s|$tochange|$changeto|; + } + + if (not $changed) { + $self->{pbot}->{logger}->log("($from) $nick!$user\@$host: failed to change '$trigger' 's$delim$tochange$delim$changeto$delim\n"); + return "Change $trigger failed."; + } + return ""; + }; + + if ($@) { + my $err = $@; + $err =~ s/ at PBot\/FactoidCommand.*$//; + return "/msg $nick Change $trigger_name failed: $err"; + } + return $ret if length $ret; + } + + if (length $action > 8000 and not $self->{pbot}->{capabilities}->userhas($userinfo, 'admin')) { return "Change $trigger_name failed; result is too long."; } + + if (not length $action) { return "Change $trigger_name failed; factoids cannot be empty."; } + + $self->{pbot}->{logger}->log("($from) $nick!$user\@$host: changed '$trigger' 's/$tochange/$changeto/\n"); + + $factoids_data->set($channel, $trigger, 'action', $action, 1); + $factoids_data->set($channel, $trigger, 'edited_by', "$nick!$user\@$host", 1); + $factoids_data->set($channel, $trigger, 'edited_on', gettimeofday); + $self->log_factoid($channel, $trigger, "$nick!$user\@$host", "changed to $action"); + return "Changed: $trigger_name is $action"; } 1; diff --git a/PBot/Factoids.pm b/PBot/Factoids.pm index da8058cb..3faebc95 100644 --- a/PBot/Factoids.pm +++ b/PBot/Factoids.pm @@ -30,1083 +30,1022 @@ use PBot::Utils::Indefinite; use PBot::Utils::ValidateString; sub initialize { - my ($self, %conf) = @_; - my $filename = $conf{filename}; - $self->{factoids} = PBot::DualIndexHashObject->new(name => 'Factoids', filename => $filename, pbot => $self->{pbot}); + my ($self, %conf) = @_; + my $filename = $conf{filename}; + $self->{factoids} = PBot::DualIndexHashObject->new(name => 'Factoids', filename => $filename, pbot => $self->{pbot}); - $self->{pbot} = $self->{pbot}; - $self->{commands} = PBot::FactoidCommands->new(pbot => $self->{pbot}); + $self->{pbot} = $self->{pbot}; + $self->{commands} = PBot::FactoidCommands->new(pbot => $self->{pbot}); - $self->{pbot}->{registry}->add_default('text', 'factoids', 'default_rate_limit', 15); - $self->{pbot}->{registry}->add_default('text', 'factoids', 'max_name_length', 100); - $self->{pbot}->{registry}->add_default('text', 'factoids', 'max_content_length', 1024 * 8); - $self->{pbot}->{registry}->add_default('text', 'factoids', 'max_channel_length', 20); + $self->{pbot}->{registry}->add_default('text', 'factoids', 'default_rate_limit', 15); + $self->{pbot}->{registry}->add_default('text', 'factoids', 'max_name_length', 100); + $self->{pbot}->{registry}->add_default('text', 'factoids', 'max_content_length', 1024 * 8); + $self->{pbot}->{registry}->add_default('text', 'factoids', 'max_channel_length', 20); - $self->{pbot}->{atexit}->register(sub { $self->save_factoids; return; }); - $self->load_factoids; + $self->{pbot}->{atexit}->register(sub { $self->save_factoids; return; }); + $self->load_factoids; } sub load_factoids { - my $self = shift; - $self->{factoids}->load; + my $self = shift; + $self->{factoids}->load; - my ($text, $regex, $modules); - foreach my $channel ($self->{factoids}->get_keys) { - foreach my $trigger ($self->{factoids}->get_keys($channel)) { - next if $trigger eq '_name'; - $self->{pbot}->{logger}->log("Missing type for $channel->$trigger\n") if not $self->{factoids}->get_data($channel, $trigger, 'type'); - $text++ if $self->{factoids}->get_data($channel, $trigger, 'type') eq 'text'; - $regex++ if $self->{factoids}->get_data($channel, $trigger, 'type') eq 'regex'; - $modules++ if $self->{factoids}->get_data($channel, $trigger, 'type') eq 'module'; + my ($text, $regex, $modules); + foreach my $channel ($self->{factoids}->get_keys) { + foreach my $trigger ($self->{factoids}->get_keys($channel)) { + next if $trigger eq '_name'; + $self->{pbot}->{logger}->log("Missing type for $channel->$trigger\n") if not $self->{factoids}->get_data($channel, $trigger, 'type'); + $text++ if $self->{factoids}->get_data($channel, $trigger, 'type') eq 'text'; + $regex++ if $self->{factoids}->get_data($channel, $trigger, 'type') eq 'regex'; + $modules++ if $self->{factoids}->get_data($channel, $trigger, 'type') eq 'module'; + } } - } - $self->{pbot}->{logger}->log(" " . ($text + $regex + $modules) . " factoids loaded ($text text, $regex regexs, $modules modules).\n"); + $self->{pbot}->{logger}->log(" " . ($text + $regex + $modules) . " factoids loaded ($text text, $regex regexs, $modules modules).\n"); } sub save_factoids { - my $self = shift; - $self->{factoids}->save; - $self->export_factoids; + my $self = shift; + $self->{factoids}->save; + $self->export_factoids; } sub get_meta { - my ($self, $channel, $trigger, $key) = @_; - $channel = lc $channel; - $trigger = lc $trigger; - my ($chan, $trig) = $self->find_factoid($channel, $trigger, exact_channel => 1); - return undef if not defined $chan; - return $self->{factoids}->get_data($chan, $trig, $key); + my ($self, $channel, $trigger, $key) = @_; + $channel = lc $channel; + $trigger = lc $trigger; + my ($chan, $trig) = $self->find_factoid($channel, $trigger, exact_channel => 1); + return undef if not defined $chan; + return $self->{factoids}->get_data($chan, $trig, $key); } sub add_factoid { - my $self = shift; - my ($type, $channel, $owner, $trigger, $action, $dont_save) = @_; - $type = lc $type; - $channel = '.*' if $channel !~ /^#/; + my $self = shift; + my ($type, $channel, $owner, $trigger, $action, $dont_save) = @_; + $type = lc $type; + $channel = '.*' if $channel !~ /^#/; - my $data; - if ($self->{factoids}->exists($channel, $trigger)) { - # only update action field if force-adding it through factadd -f - $data = $self->{factoids}->get_data($channel, $trigger); - $data->{action} = $action; - $data->{type} = $type; - } else { - $data = { - enabled => 1, - type => $type, - action => $action, - owner => $owner, - created_on => scalar gettimeofday, - ref_count => 0, - ref_user => "nobody", - rate_limit => $self->{pbot}->{registry}->get_value('factoids', 'default_rate_limit') - }; - } + my $data; + if ($self->{factoids}->exists($channel, $trigger)) { - $self->{commands}->log_factoid($channel, $trigger, $owner, "created: $action") unless $dont_save; - $self->{factoids}->add($channel, $trigger, $data, $dont_save); + # only update action field if force-adding it through factadd -f + $data = $self->{factoids}->get_data($channel, $trigger); + $data->{action} = $action; + $data->{type} = $type; + } else { + $data = { + enabled => 1, + type => $type, + action => $action, + owner => $owner, + created_on => scalar gettimeofday, + ref_count => 0, + ref_user => "nobody", + rate_limit => $self->{pbot}->{registry}->get_value('factoids', 'default_rate_limit') + }; + } + + $self->{commands}->log_factoid($channel, $trigger, $owner, "created: $action") unless $dont_save; + $self->{factoids}->add($channel, $trigger, $data, $dont_save); } sub remove_factoid { - my $self = shift; - my ($channel, $trigger) = @_; - $channel = '.*' if $channel !~ /^#/; - $self->{factoids}->remove($channel, $trigger); + my $self = shift; + my ($channel, $trigger) = @_; + $channel = '.*' if $channel !~ /^#/; + $self->{factoids}->remove($channel, $trigger); } sub export_factoids { - my $self = shift; - my $filename; + my $self = shift; + my $filename; - if (@_) { $filename = shift; } else { $filename = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/factoids.html'; } - return if not defined $filename; + if (@_) { $filename = shift; } + else { $filename = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/factoids.html'; } + return if not defined $filename; - open FILE, "> $filename" or return "Could not open export path."; + open FILE, "> $filename" or return "Could not open export path."; - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - my $time = localtime; - print FILE "\n\n"; - print FILE '' . "\n"; - print FILE '' . "\n"; - print FILE '' . "\n"; - print FILE "\nLast updated at $time\n"; - print FILE "

$botnick\'s factoids

\n"; + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + my $time = localtime; + print FILE "\n\n"; + print FILE '' . "\n"; + print FILE '' . "\n"; + print FILE '' . "\n"; + print FILE "\nLast updated at $time\n"; + print FILE "

$botnick\'s factoids

\n"; - my $i = 0; - my $table_id = 1; + my $i = 0; + my $table_id = 1; - foreach my $channel (sort $self->{factoids}->get_keys) { - next if not $self->{factoids}->get_keys($channel); - my $chan = $self->{factoids}->get_data($channel, '_name'); - $chan = 'global' if $chan eq '.*'; + foreach my $channel (sort $self->{factoids}->get_keys) { + next if not $self->{factoids}->get_keys($channel); + my $chan = $self->{factoids}->get_data($channel, '_name'); + $chan = 'global' if $chan eq '.*'; - print FILE "" . encode_entities($chan) . "
\n"; - } - - foreach my $channel (sort $self->{factoids}->get_keys) { - next if not $self->{factoids}->get_keys($channel); - my $chan = $self->{factoids}->get_data($channel, '_name'); - $chan = 'global' if $chan eq '.*'; - print FILE "\n"; - print FILE "
\n

" . encode_entities($chan) . "

\n
\n"; - print FILE "\n"; - print FILE "\n\n"; - print FILE "\n"; - print FILE "\n"; - print FILE "\n"; - print FILE "\n"; - print FILE "\n"; - print FILE "\n"; - print FILE "\n"; - print FILE "\n"; - print FILE "\n\n\n"; - $table_id++; - - foreach my $trigger (sort $self->{factoids}->get_keys($channel)) { - my $trigger_name = $self->{factoids}->get_data($channel, $trigger, '_name'); - if ($self->{factoids}->get_data($channel, $trigger, 'type') eq 'text') { - $i++; - if ($i % 2) { - print FILE "\n"; - } else { - print FILE "\n"; - } - - print FILE "\n"; - print FILE "\n"; - - print FILE "\n"; - - my $action = $self->{factoids}->get_data($channel, $trigger, 'action'); - - if ($action =~ m/https?:\/\/[^ ]+/) { - $action =~ s/(.*?)http(s?:\/\/[^ ]+)/encode_entities($1) . "http" . encode_entities($2) . "<\/a>"/ge; - $action =~ s/(.*)<\/a>(.*$)/"$1<\/a>" . encode_entities($2)/e; - } else { - $action = encode_entities($action); - } - - if ($self->{factoids}->exists($channel, $trigger, 'action_with_args')) { - my $with_args = $self->{factoids}->get_data($channel, $trigger, 'action_with_args'); - $with_args =~ s/(.*?)http(s?:\/\/[^ ]+)/encode_entities($1) . "http" . encode_entities($2) . "<\/a>"/ge; - $with_args =~ s/(.*)<\/a>(.*$)/"$1<\/a>" . encode_entities($2)/e; - print FILE "\n"; - } else { - print FILE "\n"; - } - - if ($self->{factoids}->exists($channel, $trigger, 'edited_by')) { - print FILE "\n"; - print FILE "\n"; - } else { - print FILE "\n"; - print FILE "\n"; - } - - print FILE "\n"; - - if ($self->{factoids}->exists($channel, $trigger, 'last_referenced_on')) { - print FILE "\n"; - } else { - print FILE "\n"; - } - - print FILE "\n"; - } + print FILE "" . encode_entities($chan) . "
\n"; } - print FILE "\n
ownercreated ontimes referencedfactoidlast edited byedited datelast referenced bylast referenced date
" . encode_entities($self->{factoids}->get_data($channel, $trigger, 'owner')) . "" . encode_entities(strftime "%Y/%m/%d %H:%M:%S", localtime $self->{factoids}->get_data($channel, $trigger, 'created_on')) . "" . $self->{factoids}->get_data($channel, $trigger, 'ref_count') . "" . encode_entities($trigger_name) . " is $action

with_args: " . encode_entities($with_args) . "		" . encode_entities($trigger_name) . " is $action" . $self->{factoids}->get_data($channel, $trigger, 'edited_by') . "" . encode_entities(strftime "%Y/%m/%d %H:%M:%S", localtime $self->{factoids}->get_data($channel, $trigger, 'edited_on')) . "" . encode_entities($self->{factoids}->get_data($channel, $trigger, 'ref_user')) . "" . encode_entities(strftime "%Y/%m/%d %H:%M:%S", localtime $self->{factoids}->get_data($channel, $trigger, 'last_referenced_on')) . "
\n"; - } - print FILE "
$i factoids memorized.
"; - print FILE "
Last updated at $time\n"; + foreach my $channel (sort $self->{factoids}->get_keys) { + next if not $self->{factoids}->get_keys($channel); + my $chan = $self->{factoids}->get_data($channel, '_name'); + $chan = 'global' if $chan eq '.*'; + print FILE "\n"; + print FILE "
\n

" . encode_entities($chan) . "

\n
\n"; + print FILE "\n"; + print FILE "\n\n"; + print FILE "\n"; + print FILE "\n"; + print FILE "\n"; + print FILE "\n"; + print FILE "\n"; + print FILE "\n"; + print FILE "\n"; + print FILE "\n"; + print FILE "\n\n\n"; + $table_id++; - print FILE "\n"; - print FILE "\n\n"; + 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 "\n"; + print FILE "\n\n"; - close(FILE); + close(FILE); - return "/say $i factoids exported."; + return "/say $i factoids exported."; } sub find_factoid { - my ($self, $from, $keyword, %opts) = @_; + my ($self, $from, $keyword, %opts) = @_; - my %default_opts = ( - arguments => '', - exact_channel => 0, - exact_trigger => 0, - find_alias => 0 - ); + my %default_opts = ( + arguments => '', + exact_channel => 0, + exact_trigger => 0, + find_alias => 0 + ); - %opts = (%default_opts, %opts); + %opts = (%default_opts, %opts); - my $debug = 0; - - if ($debug) { - use Data::Dumper; - my $dump = Dumper \%opts; - $self->{pbot}->{logger}->log("find_factiod: from: $from, kw: $keyword, opts: $dump\n"); - } - - $from = '.*' if not defined $from or $from !~ /^#/; - $from = lc $from; - $keyword = lc $keyword; - - $self->{pbot}->{logger}->log("from: $from\n") if $debug; - - my $arguments = $opts{arguments}; - - my @result = eval { - my @results; - for (my $depth = 0; $depth < 5; $depth++) { - my $string = $keyword . (length $arguments ? " $arguments" : ""); - $self->{pbot}->{logger}->log("string: $string\n") if $debug; - # check factoids - foreach my $channel (sort $self->{factoids}->get_keys) { - if ($opts{exact_channel}) { - if ($opts{exact_trigger} == 1) { - next unless $from eq lc $channel; - } else { - next unless $from eq lc $channel or $channel eq '.*'; - } - } - - foreach my $trigger ($self->{factoids}->get_keys($channel)) { - if ($keyword eq $trigger) { - $self->{pbot}->{logger}->log("return $channel: $trigger\n") if $debug; - - if ($opts{find_alias} && $self->{factoids}->get_data($channel, $trigger, 'action') =~ /^\/call\s+(.*)$/ms) { - my $command; - if (length $arguments) { - $command = "$1 $arguments"; - } else { - $command = $1; - } - my $arglist = $self->{pbot}->{interpreter}->make_args($command); - ($keyword, $arguments) = $self->{pbot}->{interpreter}->split_args($arglist, 2, 0, 1); - goto NEXT_DEPTH; - } - - if ($opts{exact_channel} == 1) { - return ($channel, $trigger); - } else { - push @results, [$channel, $trigger]; - } - } - } - } - - # then check regex factoids - if (not $opts{exact_trigger}) { - foreach my $channel ($self->{factoids}->get_keys) { - if ($opts{exact_channel}) { - next unless $from eq lc $channel or $channel eq '.*'; - } - - foreach my $trigger (sort $self->{factoids}->get_keys($channel)) { - next if $trigger eq '_name'; - if ($self->{factoids}->get_data($channel, $trigger, 'type') eq 'regex') { - $self->{pbot}->{logger}->log("checking regex $string =~ m/$trigger/i\n") if $debug >= 2; - if ($string =~ m/$trigger/i) { - $self->{pbot}->{logger}->log("return regex $channel: $trigger\n") if $debug; - - if ($opts{find_alias}) { - my $command = $self->{factoids}->get_data($channel, $trigger, 'action'); - my $arglist = $self->{pbot}->{interpreter}->make_args($command); - ($keyword, $arguments) = $self->{pbot}->{interpreter}->split_args($arglist, 2, 0, 1); - $string = $keyword . (length $arguments ? " $arguments" : ""); - goto NEXT_DEPTH; - } - - if ($opts{exact_channel} == 1) { - return ($channel, $trigger); - } else { - push @results, [$channel, $trigger]; - } - } - } - } - } - } - - NEXT_DEPTH: - last if not $opts{find_alias}; - } + my $debug = 0; if ($debug) { - if (not @results) { - $self->{pbot}->{logger}->log("find_factoid: no match\n"); - } else { - $self->{pbot}->{logger}->log("find_factoid: got results: " . (join ', ', map { "$_->[0] -> $_->[1]" } @results) . "\n"); - } + use Data::Dumper; + my $dump = Dumper \%opts; + $self->{pbot}->{logger}->log("find_factiod: from: $from, kw: $keyword, opts: $dump\n"); } - return @results; - }; - if ($@) { - $self->{pbot}->{logger}->log("find_factoid: bad regex: $@\n"); - return undef; - } + $from = '.*' if not defined $from or $from !~ /^#/; + $from = lc $from; + $keyword = lc $keyword; - return @result; + $self->{pbot}->{logger}->log("from: $from\n") if $debug; + + my $arguments = $opts{arguments}; + + my @result = eval { + my @results; + for (my $depth = 0; $depth < 5; $depth++) { + my $string = $keyword . (length $arguments ? " $arguments" : ""); + $self->{pbot}->{logger}->log("string: $string\n") if $debug; + + # check factoids + foreach my $channel (sort $self->{factoids}->get_keys) { + if ($opts{exact_channel}) { + if ($opts{exact_trigger} == 1) { next unless $from eq lc $channel; } + else { next unless $from eq lc $channel or $channel eq '.*'; } + } + + foreach my $trigger ($self->{factoids}->get_keys($channel)) { + if ($keyword eq $trigger) { + $self->{pbot}->{logger}->log("return $channel: $trigger\n") if $debug; + + if ($opts{find_alias} && $self->{factoids}->get_data($channel, $trigger, 'action') =~ /^\/call\s+(.*)$/ms) { + my $command; + if (length $arguments) { $command = "$1 $arguments"; } + else { $command = $1; } + my $arglist = $self->{pbot}->{interpreter}->make_args($command); + ($keyword, $arguments) = $self->{pbot}->{interpreter}->split_args($arglist, 2, 0, 1); + goto NEXT_DEPTH; + } + + if ($opts{exact_channel} == 1) { return ($channel, $trigger); } + else { push @results, [$channel, $trigger]; } + } + } + } + + # then check regex factoids + if (not $opts{exact_trigger}) { + foreach my $channel ($self->{factoids}->get_keys) { + if ($opts{exact_channel}) { next unless $from eq lc $channel or $channel eq '.*'; } + + foreach my $trigger (sort $self->{factoids}->get_keys($channel)) { + next if $trigger eq '_name'; + if ($self->{factoids}->get_data($channel, $trigger, 'type') eq 'regex') { + $self->{pbot}->{logger}->log("checking regex $string =~ m/$trigger/i\n") if $debug >= 2; + if ($string =~ m/$trigger/i) { + $self->{pbot}->{logger}->log("return regex $channel: $trigger\n") if $debug; + + if ($opts{find_alias}) { + my $command = $self->{factoids}->get_data($channel, $trigger, 'action'); + my $arglist = $self->{pbot}->{interpreter}->make_args($command); + ($keyword, $arguments) = $self->{pbot}->{interpreter}->split_args($arglist, 2, 0, 1); + $string = $keyword . (length $arguments ? " $arguments" : ""); + goto NEXT_DEPTH; + } + + if ($opts{exact_channel} == 1) { return ($channel, $trigger); } + else { push @results, [$channel, $trigger]; } + } + } + } + } + } + + NEXT_DEPTH: + last if not $opts{find_alias}; + } + + if ($debug) { + if (not @results) { $self->{pbot}->{logger}->log("find_factoid: no match\n"); } + else { + $self->{pbot}->{logger}->log("find_factoid: got results: " . (join ', ', map { "$_->[0] -> $_->[1]" } @results) . "\n"); + } + } + return @results; + }; + + if ($@) { + $self->{pbot}->{logger}->log("find_factoid: bad regex: $@\n"); + return undef; + } + + return @result; } sub escape_json { - my ($self, $text) = @_; - my $thing = {thing => $text}; - my $json = encode_json $thing; - $json =~ s/^{".*":"//; - $json =~ s/"}$//; - return $json; + my ($self, $text) = @_; + my $thing = {thing => $text}; + my $json = encode_json $thing; + $json =~ s/^{".*":"//; + $json =~ s/"}$//; + return $json; } sub expand_special_vars { - my ($self, $from, $nick, $root_keyword, $action) = @_; + my ($self, $from, $nick, $root_keyword, $action) = @_; - $action =~ s/\$nick:json|\$\{nick:json\}/$self->escape_json($nick)/ge; - $action =~ s/\$channel:json|\$\{channel:json\}/$self->escape_json($from)/ge; - $action =~ s/\$randomnick:json|\$\{randomnick:json\}/my $random = $self->{pbot}->{nicklist}->random_nick($from); $random ? $self->escape_json($random) : $self->escape_json($nick)/ge; - $action =~ s/\$0:json|\$\{0:json\}/$self->escape_json($root_keyword)/ge; + $action =~ s/\$nick:json|\$\{nick:json\}/$self->escape_json($nick)/ge; + $action =~ s/\$channel:json|\$\{channel:json\}/$self->escape_json($from)/ge; + $action =~ + s/\$randomnick:json|\$\{randomnick:json\}/my $random = $self->{pbot}->{nicklist}->random_nick($from); $random ? $self->escape_json($random) : $self->escape_json($nick)/ge; + $action =~ s/\$0:json|\$\{0:json\}/$self->escape_json($root_keyword)/ge; - $action =~ s/\$nick|\$\{nick\}/$nick/g; - $action =~ s/\$channel|\$\{channel\}/$from/g; - $action =~ s/\$randomnick|\$\{randomnick\}/my $random = $self->{pbot}->{nicklist}->random_nick($from); $random ? $random : $nick/ge; - $action =~ s/\$0\b|\$\{0\}\b/$root_keyword/g; + $action =~ s/\$nick|\$\{nick\}/$nick/g; + $action =~ s/\$channel|\$\{channel\}/$from/g; + $action =~ s/\$randomnick|\$\{randomnick\}/my $random = $self->{pbot}->{nicklist}->random_nick($from); $random ? $random : $nick/ge; + $action =~ s/\$0\b|\$\{0\}\b/$root_keyword/g; - return validate_string($action, $self->{pbot}->{registry}->get_value('factoids', 'max_content_length')); + return validate_string($action, $self->{pbot}->{registry}->get_value('factoids', 'max_content_length')); } sub expand_factoid_vars { - my ($self, $stuff, @exclude) = @_; - my $from = length $stuff->{ref_from} ? $stuff->{ref_from} : $stuff->{from}; - my $nick = $stuff->{nick}; - my $root_keyword = $stuff->{keyword_override} ? $stuff->{keyword_override} : $stuff->{root_keyword}; - my $action = $stuff->{action}; + my ($self, $stuff, @exclude) = @_; - my $debug = 0; - my $depth = 0; + my $from = length $stuff->{ref_from} ? $stuff->{ref_from} : $stuff->{from}; + my $nick = $stuff->{nick}; + my $root_keyword = $stuff->{keyword_override} ? $stuff->{keyword_override} : $stuff->{root_keyword}; + my $action = $stuff->{action}; - if ($debug) { - $self->{pbot}->{logger}->log("enter expand_factoid_vars\n"); - use Data::Dumper; - $self->{pbot}->{logger}->log(Dumper $stuff); - } + my $debug = 0; + my $depth = 0; - if ($action =~ m/^\/call --keyword-override=([^ ]+)/i) { - $root_keyword = $1; - } - - while (1) { - last if ++$depth >= 1000; - - my $offset = 0; - my $matches = 0; - my $expansions = 0; - $action =~ s/\$0/$root_keyword/g; - my $const_action = $action; - - $self->{pbot}->{logger}->log("action: $const_action\n") if $debug; - - while ($const_action =~ /(\ba\s*|\ban\s*)?(?= 1000; - - $self->{pbot}->{logger}->log("v: [$original_v], test v: [$test_v]\n") if $debug; - - $matches++; - - $test_v =~ s/\{(.+)\}/$1/; - - my $modifier = ''; - if ($test_v =~ s/(:.*)$//) { - $modifier = $1; - } - - if ($modifier =~ m/^:(#[^:]+|global)/i) { - $from = $1; - $from = '.*' if lc $from eq 'global'; - } - - my $recurse = 0; - ALIAS: - my @factoids = $self->find_factoid($from, $test_v, exact_channel => 2, exact_trigger => 2); - next if not @factoids or not $factoids[0]; - - my ($var_chan, $var) = ($factoids[0]->[0], $factoids[0]->[1]); - - if ($self->{factoids}->get_data($var_chan, $var, 'action') =~ m{^/call (.*)}ms) { - $test_v = $1; - next if ++$recurse > 100; - goto ALIAS; - } - - if ($self->{factoids}->get_data($var_chan, $var, 'type') eq 'text') { - my $change = $self->{factoids}->get_data($var_chan, $var, 'action'); - my @list = $self->{pbot}->{interpreter}->split_line($change); - my @mylist; - for (my $i = 0; $i <= $#list; $i++) { - push @mylist, $list[$i] if defined $list[$i] and length $list[$i]; - } - my $line = int(rand($#mylist + 1)); - if (not $mylist[$line] =~ s/^"(.*)"$/$1/) { - $mylist[$line] =~ s/^'(.*)'$/$1/; - } - - foreach my $mod (split /:/, $modifier) { - next if not length $mod; - - if ($mylist[$line] =~ /^\$\{\$([a-zA-Z0-9_:#]+)\}(.*)$/) { - $mylist[$line] = "\${\$$1:$mod}$2"; - next; - } elsif ($mylist[$line] =~ /^\$\{([a-zA-Z0-9_:#]+)\}(.*)$/) { - $mylist[$line] = "\${$1:$mod}$2"; - next; - } elsif ($mylist[$line] =~ /^\$\$([a-zA-Z0-9_:#]+)(.*)$/) { - $mylist[$line] = "\${\$$1:$mod}$2"; - next; - } elsif ($mylist[$line] =~ /^\$([a-zA-Z0-9_:#]+)(.*)$/) { - $mylist[$line] = "\${$1:$mod}$2"; - next; - } - - given ($mod) { - when ('uc') { - $mylist[$line] = uc $mylist[$line]; - } - when ('lc') { - $mylist[$line] = lc $mylist[$line]; - } - when ('ucfirst') { - $mylist[$line] = ucfirst $mylist[$line]; - } - when ('title') { - $mylist[$line] = ucfirst lc $mylist[$line]; - $mylist[$line] =~ s/ (\w)/' ' . uc $1/ge; - } - when ('json') { - $mylist[$line] = $self->escape_json($mylist[$line]); - } - } - } - - my $replacement = $mylist[$line]; - - if ($a) { - my $fixed_a = select_indefinite_article $mylist[$line]; - $fixed_a = ucfirst $fixed_a if $a =~ m/^A/; - $replacement = "$fixed_a $mylist[$line]"; - } - - if ($debug and $offset == 0) { - $self->{pbot}->{logger}->log(("-" x 40) . "\n"); - } - - $original_v = quotemeta $original_v; - $original_v =~ s/\\:/:/g; - - if (not length $mylist[$line]) { - $self->{pbot}->{logger}->log("No length!\n") if $debug; - if ($debug) { - $self->{pbot}->{logger}->log("before: v: $original_v, offset: $offset\n"); - $self->{pbot}->{logger}->log("$action\n"); - $self->{pbot}->{logger}->log((" " x $offset) . "^\n"); - } - - substr($action, $offset) =~ s/$a\$$original_v ?/$replacement/; - $offset += $-[0] + length $replacement; - - if ($debug) { - $self->{pbot}->{logger}->log("after: r: EMPTY \$-[0]: $-[0], offset: $offset\n"); - $self->{pbot}->{logger}->log("$action\n"); - $self->{pbot}->{logger}->log((" " x $offset) . "^\n"); - } - } else { - if ($debug) { - $self->{pbot}->{logger}->log("before: v: $original_v, offset: $offset\n"); - $self->{pbot}->{logger}->log("$action\n"); - $self->{pbot}->{logger}->log((" " x $offset) . "^\n"); - } - - substr($action, $offset) =~ s/$a\$$original_v/$replacement/; - $offset += $-[0] + length $replacement; - - if ($debug) { - $self->{pbot}->{logger}->log("after: r: $replacement, \$-[0]: $-[0], offset: $offset\n"); - $self->{pbot}->{logger}->log("$action\n"); - $self->{pbot}->{logger}->log((" " x $offset) . "^\n"); - } - } - $expansions++; - } + if ($debug) { + $self->{pbot}->{logger}->log("enter expand_factoid_vars\n"); + use Data::Dumper; + $self->{pbot}->{logger}->log(Dumper $stuff); } - last if $matches == 0 or $expansions == 0; - } - $action =~ s/\\\$/\$/g; + if ($action =~ m/^\/call --keyword-override=([^ ]+)/i) { $root_keyword = $1; } - unless (@exclude) { - $action = $self->expand_special_vars($from, $nick, $root_keyword, $action); - } + while (1) { + last if ++$depth >= 1000; - return validate_string($action, $self->{pbot}->{registry}->get_value('factoids', 'max_content_length')); + my $offset = 0; + my $matches = 0; + my $expansions = 0; + $action =~ s/\$0/$root_keyword/g; + my $const_action = $action; + + $self->{pbot}->{logger}->log("action: $const_action\n") if $debug; + + while ($const_action =~ /(\ba\s*|\ban\s*)?(?= 1000; + + $self->{pbot}->{logger}->log("v: [$original_v], test v: [$test_v]\n") if $debug; + + $matches++; + + $test_v =~ s/\{(.+)\}/$1/; + + my $modifier = ''; + if ($test_v =~ s/(:.*)$//) { $modifier = $1; } + + if ($modifier =~ m/^:(#[^:]+|global)/i) { + $from = $1; + $from = '.*' if lc $from eq 'global'; + } + + my $recurse = 0; + ALIAS: + my @factoids = $self->find_factoid($from, $test_v, exact_channel => 2, exact_trigger => 2); + next if not @factoids or not $factoids[0]; + + my ($var_chan, $var) = ($factoids[0]->[0], $factoids[0]->[1]); + + if ($self->{factoids}->get_data($var_chan, $var, 'action') =~ m{^/call (.*)}ms) { + $test_v = $1; + next if ++$recurse > 100; + goto ALIAS; + } + + if ($self->{factoids}->get_data($var_chan, $var, 'type') eq 'text') { + my $change = $self->{factoids}->get_data($var_chan, $var, 'action'); + my @list = $self->{pbot}->{interpreter}->split_line($change); + my @mylist; + for (my $i = 0; $i <= $#list; $i++) { push @mylist, $list[$i] if defined $list[$i] and length $list[$i]; } + my $line = int(rand($#mylist + 1)); + if (not $mylist[$line] =~ s/^"(.*)"$/$1/) { $mylist[$line] =~ s/^'(.*)'$/$1/; } + + foreach my $mod (split /:/, $modifier) { + next if not length $mod; + + if ($mylist[$line] =~ /^\$\{\$([a-zA-Z0-9_:#]+)\}(.*)$/) { + $mylist[$line] = "\${\$$1:$mod}$2"; + next; + } elsif ($mylist[$line] =~ /^\$\{([a-zA-Z0-9_:#]+)\}(.*)$/) { + $mylist[$line] = "\${$1:$mod}$2"; + next; + } elsif ($mylist[$line] =~ /^\$\$([a-zA-Z0-9_:#]+)(.*)$/) { + $mylist[$line] = "\${\$$1:$mod}$2"; + next; + } elsif ($mylist[$line] =~ /^\$([a-zA-Z0-9_:#]+)(.*)$/) { + $mylist[$line] = "\${$1:$mod}$2"; + next; + } + + given ($mod) { + when ('uc') { $mylist[$line] = uc $mylist[$line]; } + when ('lc') { $mylist[$line] = lc $mylist[$line]; } + when ('ucfirst') { $mylist[$line] = ucfirst $mylist[$line]; } + when ('title') { + $mylist[$line] = ucfirst lc $mylist[$line]; + $mylist[$line] =~ s/ (\w)/' ' . uc $1/ge; + } + when ('json') { $mylist[$line] = $self->escape_json($mylist[$line]); } + } + } + + my $replacement = $mylist[$line]; + + if ($a) { + my $fixed_a = select_indefinite_article $mylist[$line]; + $fixed_a = ucfirst $fixed_a if $a =~ m/^A/; + $replacement = "$fixed_a $mylist[$line]"; + } + + if ($debug and $offset == 0) { $self->{pbot}->{logger}->log(("-" x 40) . "\n"); } + + $original_v = quotemeta $original_v; + $original_v =~ s/\\:/:/g; + + if (not length $mylist[$line]) { + $self->{pbot}->{logger}->log("No length!\n") if $debug; + if ($debug) { + $self->{pbot}->{logger}->log("before: v: $original_v, offset: $offset\n"); + $self->{pbot}->{logger}->log("$action\n"); + $self->{pbot}->{logger}->log((" " x $offset) . "^\n"); + } + + substr($action, $offset) =~ s/$a\$$original_v ?/$replacement/; + $offset += $-[0] + length $replacement; + + if ($debug) { + $self->{pbot}->{logger}->log("after: r: EMPTY \$-[0]: $-[0], offset: $offset\n"); + $self->{pbot}->{logger}->log("$action\n"); + $self->{pbot}->{logger}->log((" " x $offset) . "^\n"); + } + } else { + if ($debug) { + $self->{pbot}->{logger}->log("before: v: $original_v, offset: $offset\n"); + $self->{pbot}->{logger}->log("$action\n"); + $self->{pbot}->{logger}->log((" " x $offset) . "^\n"); + } + + substr($action, $offset) =~ s/$a\$$original_v/$replacement/; + $offset += $-[0] + length $replacement; + + if ($debug) { + $self->{pbot}->{logger}->log("after: r: $replacement, \$-[0]: $-[0], offset: $offset\n"); + $self->{pbot}->{logger}->log("$action\n"); + $self->{pbot}->{logger}->log((" " x $offset) . "^\n"); + } + } + $expansions++; + } + } + last if $matches == 0 or $expansions == 0; + } + + $action =~ s/\\\$/\$/g; + + unless (@exclude) { $action = $self->expand_special_vars($from, $nick, $root_keyword, $action); } + + return validate_string($action, $self->{pbot}->{registry}->get_value('factoids', 'max_content_length')); } sub expand_action_arguments { - my ($self, $action, $input, $nick) = @_; + my ($self, $action, $input, $nick) = @_; - $action = validate_string($action, $self->{pbot}->{registry}->get_value('factoids', 'max_content_length')); - $input = validate_string($input, $self->{pbot}->{registry}->get_value('factoids', 'max_content_length')); + $action = validate_string($action, $self->{pbot}->{registry}->get_value('factoids', 'max_content_length')); + $input = validate_string($input, $self->{pbot}->{registry}->get_value('factoids', 'max_content_length')); - my %h; - if (not defined $input or $input eq '') { - %h = (args => $nick); - } else { - %h = (args => $input); - } + my %h; + if (not defined $input or $input eq '') { %h = (args => $nick); } + else { %h = (args => $input); } - my $jsonargs = encode_json \%h; - $jsonargs =~ s/^{".*":"//; - $jsonargs =~ s/"}$//; + my $jsonargs = encode_json \%h; + $jsonargs =~ s/^{".*":"//; + $jsonargs =~ s/"}$//; - if (not defined $input or $input eq '') { - $input = ""; - $action =~ s/\$args:json|\$\{args:json\}/$jsonargs/ge; - $action =~ s/\$args(?![[\w])|\$\{args(?![[\w])\}/$nick/g; - } else { - $action =~ s/\$args:json|\$\{args:json\}/$jsonargs/g; - $action =~ s/\$args(?![[\w])|\$\{args(?![[\w])\}/$input/g; - } - - my @args = $self->{pbot}->{interpreter}->split_line($input); - $action =~ s/\$arglen\b|\$\{arglen\}/scalar @args/eg; - - my $depth = 0; - my $const_action = $action; - while ($const_action =~ m/\$arg\[([^]]+)]|\$\{arg\[([^]]+)]\}/g) { - my $arg = defined $2 ? $2 : $1; - - last if ++$depth >= 100; - - if ($arg eq '*') { - if (not defined $input or $input eq '') { - $action =~ s/\$arg\[\*\]|\$\{arg\[\*\]\}/$nick/; - } else { - $action =~ s/\$arg\[\*\]|\$\{arg\[\*\]\}/$input/; - } - next; - } - - if ($arg =~ m/([^:]*):(.*)/) { - my $arg1 = $1; - my $arg2 = $2; - - my $arg1i = $arg1; - my $arg2i = $arg2; - - $arg1i = 0 if $arg1i eq ''; - $arg2i = $#args if $arg2i eq ''; - $arg2i = $#args if $arg2i > $#args; - - my @values = eval { - local $SIG{__WARN__} = sub {}; - return @args[$arg1i .. $arg2i]; - }; - - if ($@) { - next; - } else { - my $string = join(' ', @values); - - if ($string eq '') { - $action =~ s/\s*\$\{arg\[$arg1:$arg2\]\}// || $action =~ s/\s*\$arg\[$arg1:$arg2\]//; - } else { - $action =~ s/\$\{arg\[$arg1:$arg2\]\}/$string/ || $action =~ s/\$arg\[$arg1:$arg2\]/$string/; - } - } - - next; - } - - my $value = eval { - local $SIG{__WARN__} = sub {}; - return $args[$arg]; - }; - - if ($@) { - next; + if (not defined $input or $input eq '') { + $input = ""; + $action =~ s/\$args:json|\$\{args:json\}/$jsonargs/ge; + $action =~ s/\$args(?![[\w])|\$\{args(?![[\w])\}/$nick/g; } else { - - if (not defined $value) { - if ($arg == 0) { - $action =~ s/\$\{arg\[$arg\]\}/$nick/ || $action =~ s/\$arg\[$arg\]/$nick/; - } else { - $action =~ s/\s*\$\{arg\[$arg\]\}// || $action =~ s/\s*\$arg\[$arg\]//; - } - } else { - $action =~ s/\$arg\{\[$arg\]\}/$value/ || $action =~ s/\$arg\[$arg\]/$value/; - } + $action =~ s/\$args:json|\$\{args:json\}/$jsonargs/g; + $action =~ s/\$args(?![[\w])|\$\{args(?![[\w])\}/$input/g; } - } - return $action; + my @args = $self->{pbot}->{interpreter}->split_line($input); + $action =~ s/\$arglen\b|\$\{arglen\}/scalar @args/eg; + + my $depth = 0; + my $const_action = $action; + while ($const_action =~ m/\$arg\[([^]]+)]|\$\{arg\[([^]]+)]\}/g) { + my $arg = defined $2 ? $2 : $1; + + last if ++$depth >= 100; + + if ($arg eq '*') { + if (not defined $input or $input eq '') { $action =~ s/\$arg\[\*\]|\$\{arg\[\*\]\}/$nick/; } + else { $action =~ s/\$arg\[\*\]|\$\{arg\[\*\]\}/$input/; } + next; + } + + if ($arg =~ m/([^:]*):(.*)/) { + my $arg1 = $1; + my $arg2 = $2; + + my $arg1i = $arg1; + my $arg2i = $arg2; + + $arg1i = 0 if $arg1i eq ''; + $arg2i = $#args if $arg2i eq ''; + $arg2i = $#args if $arg2i > $#args; + + my @values = eval { + local $SIG{__WARN__} = sub { }; + return @args[$arg1i .. $arg2i]; + }; + + if ($@) { next; } + else { + my $string = join(' ', @values); + + if ($string eq '') { $action =~ s/\s*\$\{arg\[$arg1:$arg2\]\}// || $action =~ s/\s*\$arg\[$arg1:$arg2\]//; } + else { $action =~ s/\$\{arg\[$arg1:$arg2\]\}/$string/ || $action =~ s/\$arg\[$arg1:$arg2\]/$string/; } + } + + next; + } + + my $value = eval { + local $SIG{__WARN__} = sub { }; + return $args[$arg]; + }; + + if ($@) { next; } + else { + + if (not defined $value) { + if ($arg == 0) { $action =~ s/\$\{arg\[$arg\]\}/$nick/ || $action =~ s/\$arg\[$arg\]/$nick/; } + else { $action =~ s/\s*\$\{arg\[$arg\]\}// || $action =~ s/\s*\$arg\[$arg\]//; } + } else { + $action =~ s/\$arg\{\[$arg\]\}/$value/ || $action =~ s/\$arg\[$arg\]/$value/; + } + } + } + + return $action; } sub execute_code_factoid_using_vm { - my ($self, $stuff) = @_; + my ($self, $stuff) = @_; - unless ($self->{factoids}->exists($stuff->{channel}, $stuff->{keyword}, 'interpolate') and $self->{factoids}->get_data($stuff->{channel}, $stuff->{keyword}, 'interpolate') eq '0') { - if ($stuff->{code} =~ m/(?:\$\{?nick\b|\$\{?args\b|\$\{?arg\[)/ and length $stuff->{arguments}) { - $stuff->{no_nickoverride} = 1; + unless ($self->{factoids}->exists($stuff->{channel}, $stuff->{keyword}, 'interpolate') + and $self->{factoids}->get_data($stuff->{channel}, $stuff->{keyword}, 'interpolate') eq '0') + { + if ($stuff->{code} =~ m/(?:\$\{?nick\b|\$\{?args\b|\$\{?arg\[)/ and length $stuff->{arguments}) { $stuff->{no_nickoverride} = 1; } + else { $stuff->{no_nickoverride} = 0; } + + $stuff->{action} = $stuff->{code}; + $stuff->{code} = $self->expand_factoid_vars($stuff); + + if ($self->{factoids}->get_data($stuff->{channel}, $stuff->{keyword}, 'allow_empty_args')) { + $stuff->{code} = $self->expand_action_arguments($stuff->{code}, $stuff->{arguments}, ''); + } else { + $stuff->{code} = $self->expand_action_arguments($stuff->{code}, $stuff->{arguments}, $stuff->{nick}); + } } else { - $stuff->{no_nickoverride} = 0; + $stuff->{no_nickoverride} = 0; } - $stuff->{action} = $stuff->{code}; - $stuff->{code} = $self->expand_factoid_vars($stuff); + my %h = ( + nick => $stuff->{nick}, channel => $stuff->{from}, lang => $stuff->{lang}, code => $stuff->{code}, arguments => $stuff->{arguments}, + factoid => "$stuff->{channel}:$stuff->{keyword}" + ); - if ($self->{factoids}->get_data($stuff->{channel}, $stuff->{keyword}, 'allow_empty_args')) { - $stuff->{code} = $self->expand_action_arguments($stuff->{code}, $stuff->{arguments}, ''); - } else { - $stuff->{code} = $self->expand_action_arguments($stuff->{code}, $stuff->{arguments}, $stuff->{nick}); + if ($self->{factoids}->exists($stuff->{channel}, $stuff->{keyword}, 'persist-key')) { + $h{'persist-key'} = $self->{factoids}->get_data($stuff->{channel}, $stuff->{keyword}, 'persist-key'); } - } else { - $stuff->{no_nickoverride} = 0; - } - my %h = (nick => $stuff->{nick}, channel => $stuff->{from}, lang => $stuff->{lang}, code => $stuff->{code}, arguments => $stuff->{arguments}, factoid => "$stuff->{channel}:$stuff->{keyword}"); + my $json = encode_json \%h; - if ($self->{factoids}->exists($stuff->{channel}, $stuff->{keyword}, 'persist-key')) { - $h{'persist-key'} = $self->{factoids}->get_data($stuff->{channel}, $stuff->{keyword}, 'persist-key'); - } + $stuff->{special} = 'code-factoid'; + $stuff->{root_channel} = $stuff->{channel}; + $stuff->{keyword} = 'compiler'; + $stuff->{arguments} = $json; + $stuff->{args_utf8} = 1; - my $json = encode_json \%h; - - $stuff->{special} = 'code-factoid'; - $stuff->{root_channel} = $stuff->{channel}; - $stuff->{keyword} = 'compiler'; - $stuff->{arguments} = $json; - $stuff->{args_utf8} = 1; - - $self->{pbot}->{modules}->execute_module($stuff); - return ""; + $self->{pbot}->{modules}->execute_module($stuff); + return ""; } sub execute_code_factoid { - my ($self, @args) = @_; - return $self->execute_code_factoid_using_vm(@args); + my ($self, @args) = @_; + return $self->execute_code_factoid_using_vm(@args); } sub interpreter { - my ($self, $stuff) = @_; - my $pbot = $self->{pbot}; + my ($self, $stuff) = @_; + my $pbot = $self->{pbot}; - if ($self->{pbot}->{registry}->get_value('general', 'debugcontext')) { - use Data::Dumper; - $Data::Dumper::Sortkeys = 1; - $self->{pbot}->{logger}->log("Factoids::interpreter\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("Factoids::interpreter\n"); + $self->{pbot}->{logger}->log(Dumper $stuff); + } - return undef if not length $stuff->{keyword} or $stuff->{interpret_depth} > $self->{pbot}->{registry}->get_value('interpreter', 'max_recursion'); + return undef if not length $stuff->{keyword} or $stuff->{interpret_depth} > $self->{pbot}->{registry}->get_value('interpreter', 'max_recursion'); - $stuff->{from} = lc $stuff->{from}; + $stuff->{from} = lc $stuff->{from}; - my $strictnamespace = $self->{pbot}->{registry}->get_value($stuff->{from}, 'strictnamespace'); + my $strictnamespace = $self->{pbot}->{registry}->get_value($stuff->{from}, 'strictnamespace'); - if (not defined $strictnamespace) { - $strictnamespace = $self->{pbot}->{registry}->get_value('general', 'strictnamespace'); - } + if (not defined $strictnamespace) { $strictnamespace = $self->{pbot}->{registry}->get_value('general', 'strictnamespace'); } - # search for factoid against global channel and current channel (from unless ref_from is defined) - my $original_keyword = $stuff->{keyword}; - my ($channel, $keyword) = $self->find_factoid($stuff->{ref_from} ? $stuff->{ref_from} : $stuff->{from}, $stuff->{keyword}, arguments => $stuff->{arguments}, exact_channel => 1); + # search for factoid against global channel and current channel (from unless ref_from is defined) + my $original_keyword = $stuff->{keyword}; + my ($channel, $keyword) = + $self->find_factoid($stuff->{ref_from} ? $stuff->{ref_from} : $stuff->{from}, $stuff->{keyword}, arguments => $stuff->{arguments}, exact_channel => 1); - if (not $stuff->{ref_from} or $stuff->{ref_from} eq '.*' or $stuff->{ref_from} eq $stuff->{from}) { - $stuff->{ref_from} = ""; - } + if (not $stuff->{ref_from} or $stuff->{ref_from} eq '.*' or $stuff->{ref_from} eq $stuff->{from}) { $stuff->{ref_from} = ""; } - if (defined $channel and not $channel eq '.*' and not $channel eq lc $stuff->{from}) { - $stuff->{ref_from} = $channel; - } + if (defined $channel and not $channel eq '.*' and not $channel eq lc $stuff->{from}) { $stuff->{ref_from} = $channel; } - $stuff->{arguments} = "" if not defined $stuff->{arguments}; + $stuff->{arguments} = "" if not defined $stuff->{arguments}; - # if no match found, attempt to call factoid from another channel if it exists there - if (not defined $keyword) { - my $string = "$original_keyword $stuff->{arguments}"; - my $lc_keyword = lc $original_keyword; - my $comma = ""; - my $found = 0; - my $chans = ""; - my ($fwd_chan, $fwd_trig); + # if no match found, attempt to call factoid from another channel if it exists there + if (not defined $keyword) { - # build string of which channels contain the keyword, keeping track of the last one and count - foreach my $chan ($self->{factoids}->get_keys) { - foreach my $trig ($self->{factoids}->get_keys($chan)) { - my $type = $self->{factoids}->get_data($chan, $trig, 'type'); - if (($type eq 'text' or $type eq 'module') and $trig eq $lc_keyword) { - $chans .= $comma . $self->{factoids}->get_data($chan, '_name'); - $comma = ", "; - $found++; - $fwd_chan = $chan; - $fwd_trig = $trig; - last; + my $string = "$original_keyword $stuff->{arguments}"; + + my $lc_keyword = lc $original_keyword; + my $comma = ""; + my $found = 0; + my $chans = ""; + my ($fwd_chan, $fwd_trig); + + # build string of which channels contain the keyword, keeping track of the last one and count + foreach my $chan ($self->{factoids}->get_keys) { + foreach my $trig ($self->{factoids}->get_keys($chan)) { + my $type = $self->{factoids}->get_data($chan, $trig, 'type'); + if (($type eq 'text' or $type eq 'module') and $trig eq $lc_keyword) { + $chans .= $comma . $self->{factoids}->get_data($chan, '_name'); + $comma = ", "; + $found++; + $fwd_chan = $chan; + $fwd_trig = $trig; + last; + } + } } - } - } - my $ref_from = $stuff->{ref_from} ? "[$stuff->{ref_from}] " : ""; + my $ref_from = $stuff->{ref_from} ? "[$stuff->{ref_from}] " : ""; - # if multiple channels have this keyword, then ask user to disambiguate - if ($found > 1) { - return undef if $stuff->{referenced}; - return $ref_from . "Ambiguous keyword '$original_keyword' exists in multiple channels (use 'fact $original_keyword' to choose one): $chans"; - } - # if there's just one other channel that has this keyword, trigger that instance - elsif ($found == 1) { - $pbot->{logger}->log("Found '$original_keyword' as '$fwd_trig' in [$fwd_chan]\n"); - $stuff->{keyword} = $fwd_trig; - $stuff->{interpret_depth}++; - $stuff->{ref_from} = $fwd_chan; - return $pbot->{factoids}->interpreter($stuff); - } - # otherwise keyword hasn't been found, display similiar matches for all channels - else { - # if a non-nick argument was supplied, e.g., a sentence using the bot's nick, don't say anything - return undef if length $stuff->{arguments} and not $self->{pbot}->{nicklist}->is_present($stuff->{from}, $stuff->{arguments}); - - my $namespace = $strictnamespace ? $stuff->{from} : '.*'; - $namespace = '.*' if $namespace !~ /^#/; - - my $namespace_regex = $namespace; - if ($strictnamespace) { - $namespace_regex = "(?:" . (quotemeta $namespace) . '|\\.\\*)'; - } - - my $matches = $self->{commands}->factfind($stuff->{from}, $stuff->{nick}, $stuff->{user}, $stuff->{host}, quotemeta($original_keyword) . " -channel $namespace_regex"); - - # found factfind matches - if ($matches !~ m/^No factoids/) { - return undef if $stuff->{referenced}; - return "No such factoid '$original_keyword'; $matches"; - } - - # otherwise find levenshtein closest matches - $matches = $self->{factoids}->levenshtein_matches($namespace, lc $original_keyword, 0.50, $strictnamespace); - - # don't say anything if nothing similiar was found - return undef if $matches eq 'none'; - return undef if $stuff->{referenced}; - - my $ref_from = $stuff->{ref_from} ? "[$stuff->{ref_from}] " : ""; - return $ref_from . "No such factoid '$original_keyword'; did you mean $matches?"; - } - } - - my $channel_name = $self->{factoids}->get_data($channel, '_name'); - my $trigger_name = $self->{factoids}->get_data($channel, $keyword, '_name'); - $channel_name = 'global' if $channel_name eq '.*'; - $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - - $stuff->{keyword} = $keyword; - $stuff->{trigger} = $keyword; - $stuff->{channel} = $channel; - $stuff->{original_keyword} = $original_keyword; - $stuff->{channel_name} = $channel_name; - $stuff->{trigger_name} = $trigger_name; - - return undef if $stuff->{referenced} and $self->{factoids}->get_data($channel, $keyword, 'noembed'); - - if ($self->{factoids}->get_data($channel, $keyword, 'locked_to_channel')) { - if ($stuff->{ref_from} ne "") { # called from another channel - return "$trigger_name may be invoked only in $stuff->{ref_from}."; - } - } - - if ($self->{factoids}->exists($channel, $keyword, 'last_referenced_on')) { - if ($self->{factoids}->exists($channel, $keyword, 'last_referenced_in')) { - if ($self->{factoids}->get_data($channel, $keyword, 'last_referenced_in') eq $stuff->{from}) { - my $ratelimit = $self->{pbot}->{registry}->get_value($stuff->{from}, 'ratelimit_override'); - $ratelimit = $self->{factoids}->get_data($channel, $keyword, 'rate_limit') if not defined $ratelimit; - if (gettimeofday - $self->{factoids}->get_data($channel, $keyword, 'last_referenced_on') < $ratelimit) { - my $ref_from = $stuff->{ref_from} ? "[$stuff->{ref_from}] " : ""; - return "/msg $stuff->{nick} $ref_from'$trigger_name' is rate-limited; try again in " . duration ($ratelimit - int(gettimeofday - $self->{factoids}->get_data($channel, $keyword, 'last_referenced_on'))) . "." unless $self->{pbot}->{users}->loggedin_admin($channel, "$stuff->{nick}!$stuff->{user}\@$stuff->{host}"); + # if multiple channels have this keyword, then ask user to disambiguate + if ($found > 1) { + return undef if $stuff->{referenced}; + return $ref_from . "Ambiguous keyword '$original_keyword' exists in multiple channels (use 'fact $original_keyword' to choose one): $chans"; } - } - } - } - my $data = $self->{factoids}->get_data($channel, $keyword); - $data->{ref_count}++; - $data->{ref_user} = "$stuff->{nick}!$stuff->{user}\@$stuff->{host}"; - $data->{last_referenced_on} = gettimeofday; - $data->{last_referenced_in} = $stuff->{from} || "stdin"; - $self->{factoids}->add($channel, $keyword, $data, 1, 1); + # if there's just one other channel that has this keyword, trigger that instance + elsif ($found == 1) { + $pbot->{logger}->log("Found '$original_keyword' as '$fwd_trig' in [$fwd_chan]\n"); + $stuff->{keyword} = $fwd_trig; + $stuff->{interpret_depth}++; + $stuff->{ref_from} = $fwd_chan; + return $pbot->{factoids}->interpreter($stuff); + } - my $action; + # otherwise keyword hasn't been found, display similiar matches for all channels + else { + # if a non-nick argument was supplied, e.g., a sentence using the bot's nick, don't say anything + return undef if length $stuff->{arguments} and not $self->{pbot}->{nicklist}->is_present($stuff->{from}, $stuff->{arguments}); - if ($self->{factoids}->exists($channel, $keyword, 'usage') and not length $stuff->{arguments} and $self->{factoids}->get_data($channel, $keyword, 'requires_arguments')) { - $stuff->{alldone} = 1; - my $usage = $self->{factoids}->get_data($channel, $keyword, 'usage'); - $usage =~ s/\$0|\$\{0\}/$trigger_name/g; - return $usage; - } + my $namespace = $strictnamespace ? $stuff->{from} : '.*'; + $namespace = '.*' if $namespace !~ /^#/; - if (length $stuff->{arguments} and $self->{factoids}->exists($channel, $keyword, 'action_with_args')) { - $action = $self->{factoids}->get_data($channel, $keyword, 'action_with_args'); - } else { - $action = $self->{factoids}->get_data($channel, $keyword, 'action'); - } + my $namespace_regex = $namespace; + if ($strictnamespace) { $namespace_regex = "(?:" . (quotemeta $namespace) . '|\\.\\*)'; } - if ($action =~ m{^/code\s+([^\s]+)\s+(.+)$}msi) { - my ($lang, $code) = ($1, $2); + my $matches = $self->{commands}->factfind($stuff->{from}, $stuff->{nick}, $stuff->{user}, $stuff->{host}, quotemeta($original_keyword) . " -channel $namespace_regex"); - if ($self->{factoids}->exists($channel, $keyword, 'usage') and not length $stuff->{arguments}) { - $stuff->{alldone} = 1; - my $usage = $self->{factoids}->get_data($channel, $keyword, 'usage'); - $usage =~ s/\$0|\$\{0\}/$trigger_name/g; - return $usage; + # found factfind matches + if ($matches !~ m/^No factoids/) { + return undef if $stuff->{referenced}; + return "No such factoid '$original_keyword'; $matches"; + } + + # otherwise find levenshtein closest matches + $matches = $self->{factoids}->levenshtein_matches($namespace, lc $original_keyword, 0.50, $strictnamespace); + + # don't say anything if nothing similiar was found + return undef if $matches eq 'none'; + return undef if $stuff->{referenced}; + + my $ref_from = $stuff->{ref_from} ? "[$stuff->{ref_from}] " : ""; + return $ref_from . "No such factoid '$original_keyword'; did you mean $matches?"; + } } - $stuff->{lang} = $lang; - $stuff->{code} = $code; - $self->execute_code_factoid($stuff); - return ""; - } + my $channel_name = $self->{factoids}->get_data($channel, '_name'); + my $trigger_name = $self->{factoids}->get_data($channel, $keyword, '_name'); + $channel_name = 'global' if $channel_name eq '.*'; + $trigger_name = "\"$trigger_name\"" if $trigger_name =~ / /; - return $self->handle_action($stuff, $action); + $stuff->{keyword} = $keyword; + $stuff->{trigger} = $keyword; + $stuff->{channel} = $channel; + $stuff->{original_keyword} = $original_keyword; + $stuff->{channel_name} = $channel_name; + $stuff->{trigger_name} = $trigger_name; + + return undef if $stuff->{referenced} and $self->{factoids}->get_data($channel, $keyword, 'noembed'); + + if ($self->{factoids}->get_data($channel, $keyword, 'locked_to_channel')) { + if ($stuff->{ref_from} ne "") { # called from another channel + return "$trigger_name may be invoked only in $stuff->{ref_from}."; + } + } + + if ($self->{factoids}->exists($channel, $keyword, 'last_referenced_on')) { + if ($self->{factoids}->exists($channel, $keyword, 'last_referenced_in')) { + if ($self->{factoids}->get_data($channel, $keyword, 'last_referenced_in') eq $stuff->{from}) { + my $ratelimit = $self->{pbot}->{registry}->get_value($stuff->{from}, 'ratelimit_override'); + $ratelimit = $self->{factoids}->get_data($channel, $keyword, 'rate_limit') if not defined $ratelimit; + if (gettimeofday - $self->{factoids}->get_data($channel, $keyword, 'last_referenced_on') < $ratelimit) { + my $ref_from = $stuff->{ref_from} ? "[$stuff->{ref_from}] " : ""; + return + "/msg $stuff->{nick} $ref_from'$trigger_name' is rate-limited; try again in " + . duration($ratelimit - int(gettimeofday - $self->{factoids}->get_data($channel, $keyword, 'last_referenced_on'))) . "." + unless $self->{pbot}->{users}->loggedin_admin($channel, "$stuff->{nick}!$stuff->{user}\@$stuff->{host}"); + } + } + } + } + + my $data = $self->{factoids}->get_data($channel, $keyword); + $data->{ref_count}++; + $data->{ref_user} = "$stuff->{nick}!$stuff->{user}\@$stuff->{host}"; + $data->{last_referenced_on} = gettimeofday; + $data->{last_referenced_in} = $stuff->{from} || "stdin"; + $self->{factoids}->add($channel, $keyword, $data, 1, 1); + + my $action; + + if ($self->{factoids}->exists($channel, $keyword, 'usage') and not length $stuff->{arguments} and $self->{factoids}->get_data($channel, $keyword, 'requires_arguments')) { + $stuff->{alldone} = 1; + my $usage = $self->{factoids}->get_data($channel, $keyword, 'usage'); + $usage =~ s/\$0|\$\{0\}/$trigger_name/g; + return $usage; + } + + if (length $stuff->{arguments} and $self->{factoids}->exists($channel, $keyword, 'action_with_args')) { + $action = $self->{factoids}->get_data($channel, $keyword, 'action_with_args'); + } else { + $action = $self->{factoids}->get_data($channel, $keyword, 'action'); + } + + if ($action =~ m{^/code\s+([^\s]+)\s+(.+)$}msi) { + my ($lang, $code) = ($1, $2); + + if ($self->{factoids}->exists($channel, $keyword, 'usage') and not length $stuff->{arguments}) { + $stuff->{alldone} = 1; + my $usage = $self->{factoids}->get_data($channel, $keyword, 'usage'); + $usage =~ s/\$0|\$\{0\}/$trigger_name/g; + return $usage; + } + + $stuff->{lang} = $lang; + $stuff->{code} = $code; + $self->execute_code_factoid($stuff); + return ""; + } + + return $self->handle_action($stuff, $action); } sub handle_action { - my ($self, $stuff, $action) = @_; + my ($self, $stuff, $action) = @_; - if ($self->{pbot}->{registry}->get_value('general', 'debugcontext')) { - use Data::Dumper; - $Data::Dumper::Sortkeys = 1; - $self->{pbot}->{logger}->log("Factoids::handle_action [$action]\n"); - $self->{pbot}->{logger}->log(Dumper $stuff); - } - - return "" if not length $action; - - my ($channel, $keyword) = ($stuff->{channel}, $stuff->{trigger}); - my ($channel_name, $trigger_name) = ($stuff->{channel_name}, $stuff->{trigger_name}); - my $ref_from = $stuff->{ref_from} ? "[$stuff->{ref_from}] " : ""; - - unless ($self->{factoids}->exists($channel, $keyword, 'interpolate') and $self->{factoids}->get_data($channel, $keyword, 'interpolate') eq '0') { - my ($root_channel, $root_keyword) = $self->find_factoid($stuff->{ref_from} ? $stuff->{ref_from} : $stuff->{from}, $stuff->{root_keyword}, arguments => $stuff->{arguments}, exact_channel => 1); - if (not defined $root_channel or not defined $root_keyword) { - $root_channel = $channel; - $root_keyword = $keyword; + if ($self->{pbot}->{registry}->get_value('general', 'debugcontext')) { + use Data::Dumper; + $Data::Dumper::Sortkeys = 1; + $self->{pbot}->{logger}->log("Factoids::handle_action [$action]\n"); + $self->{pbot}->{logger}->log(Dumper $stuff); } - if (not length $stuff->{keyword_override} and length $self->{factoids}->get_data($root_channel, $root_keyword, 'keyword_override')) { - $stuff->{keyword_override} = $self->{factoids}->get_data($root_channel, $root_keyword, 'keyword_override'); - } - $stuff->{action} = $action; - $action = $self->expand_factoid_vars($stuff); - } - if (length $stuff->{arguments}) { - if ($action =~ m/\$\{?args/ or $action =~ m/\$\{?arg\[/) { - unless (defined $self->{factoids}->get_data($channel, $keyword, 'interpolate') and $self->{factoids}->get_data($channel, $keyword, 'interpolate') eq '0') { - $action = $self->expand_action_arguments($action, $stuff->{arguments}, $stuff->{nick}); - $stuff->{no_nickoverride} = 1; - } else { + return "" if not length $action; + + my ($channel, $keyword) = ($stuff->{channel}, $stuff->{trigger}); + my ($channel_name, $trigger_name) = ($stuff->{channel_name}, $stuff->{trigger_name}); + my $ref_from = $stuff->{ref_from} ? "[$stuff->{ref_from}] " : ""; + + unless ($self->{factoids}->exists($channel, $keyword, 'interpolate') and $self->{factoids}->get_data($channel, $keyword, 'interpolate') eq '0') { + my ($root_channel, $root_keyword) = + $self->find_factoid($stuff->{ref_from} ? $stuff->{ref_from} : $stuff->{from}, $stuff->{root_keyword}, arguments => $stuff->{arguments}, exact_channel => 1); + if (not defined $root_channel or not defined $root_keyword) { + $root_channel = $channel; + $root_keyword = $keyword; + } + if (not length $stuff->{keyword_override} and length $self->{factoids}->get_data($root_channel, $root_keyword, 'keyword_override')) { + $stuff->{keyword_override} = $self->{factoids}->get_data($root_channel, $root_keyword, 'keyword_override'); + } + $stuff->{action} = $action; + $action = $self->expand_factoid_vars($stuff); + } + + if (length $stuff->{arguments}) { + if ($action =~ m/\$\{?args/ or $action =~ m/\$\{?arg\[/) { + unless (defined $self->{factoids}->get_data($channel, $keyword, 'interpolate') and $self->{factoids}->get_data($channel, $keyword, 'interpolate') eq '0') { + $action = $self->expand_action_arguments($action, $stuff->{arguments}, $stuff->{nick}); + $stuff->{no_nickoverride} = 1; + } else { + $stuff->{no_nickoverride} = 0; + } + $stuff->{arguments} = ""; + $stuff->{original_arguments} = ""; + } else { + if ($self->{factoids}->get_data($channel, $keyword, 'type') eq 'text') { + my $target = $self->{pbot}->{nicklist}->is_present_similar($stuff->{from}, $stuff->{arguments}); + + if ($target and $action !~ /\$\{?(?:nick|args)\b/) { + $stuff->{nickoverride} = $target unless $stuff->{force_nickoverride}; + $stuff->{no_nickoverride} = 0; + } else { + $stuff->{no_nickoverride} = 1; + } + } + } + } else { + + # no arguments supplied, replace $args with $nick/$tonick, etc + if ($self->{factoids}->exists($channel, $keyword, 'usage')) { + $action = "/say " . $self->{factoids}->get_data($channel, $keyword, 'usage'); + $action =~ s/\$0|\$\{0\}/$trigger_name/g; + $stuff->{alldone} = 1; + } else { + if ($self->{factoids}->get_data($channel, $keyword, 'allow_empty_args')) { $action = $self->expand_action_arguments($action, undef, ''); } + else { $action = $self->expand_action_arguments($action, undef, $stuff->{nick}); } + } $stuff->{no_nickoverride} = 0; - } - $stuff->{arguments} = ""; - $stuff->{original_arguments} = ""; - } else { - if ($self->{factoids}->get_data($channel, $keyword, 'type') eq 'text') { - my $target = $self->{pbot}->{nicklist}->is_present_similar($stuff->{from}, $stuff->{arguments}); + } - if ($target and $action !~ /\$\{?(?:nick|args)\b/) { - $stuff->{nickoverride} = $target unless $stuff->{force_nickoverride}; - $stuff->{no_nickoverride} = 0; - } else { - $stuff->{no_nickoverride} = 1; + # Check if it's an alias + if ($action =~ /^\/call\s+(.*)$/msi) { + my $command = $1; + $command =~ s/\n$//; + unless ($self->{factoids}->get_data($channel, $keyword, 'require_explicit_args')) { + my $args = $stuff->{arguments}; + $command .= " $args" if length $args and not $stuff->{special} eq 'code-factoid'; + $stuff->{arguments} = ''; } - } - } - } else { - # no arguments supplied, replace $args with $nick/$tonick, etc - if ($self->{factoids}->exists($channel, $keyword, 'usage')) { - $action = "/say " . $self->{factoids}->get_data($channel, $keyword, 'usage'); - $action =~ s/\$0|\$\{0\}/$trigger_name/g; - $stuff->{alldone} = 1; - } else { - if ($self->{factoids}->get_data($channel, $keyword, 'allow_empty_args')) { - $action = $self->expand_action_arguments($action, undef, ''); - } else { - $action = $self->expand_action_arguments($action, undef, $stuff->{nick}); - } - } - $stuff->{no_nickoverride} = 0; - } - # Check if it's an alias - if ($action =~ /^\/call\s+(.*)$/msi) { - my $command = $1; - $command =~ s/\n$//; - unless ($self->{factoids}->get_data($channel, $keyword, 'require_explicit_args')) { - my $args = $stuff->{arguments}; - $command .= " $args" if length $args and not $stuff->{special} eq 'code-factoid'; - $stuff->{arguments} = ''; - } - - unless ($self->{factoids}->get_data($channel, $keyword, 'no_keyword_override')) { - if ($command =~ s/\s*--keyword-override=([^ ]+)\s*//) { - $stuff->{keyword_override} = $1; - } - } - - $stuff->{command} = $command; - $stuff->{aliased} = 1; - - $self->{pbot}->{logger}->log("[" . (defined $stuff->{from} ? $stuff->{from} : "stdin") . "] ($stuff->{nick}!$stuff->{user}\@$stuff->{host}) $trigger_name aliased to: $command\n"); - - if (defined $self->{factoids}->get_data($channel, $keyword, 'cap-override')) { - if ($self->{factoids}->get_data($channel, $keyword, 'locked')) { - $self->{pbot}->{logger}->log("Capability override set to " . $self->{factoids}->get_data($channel, $keyword, 'cap-override') . "\n"); - $stuff->{'cap-override'} = $self->{factoids}->get_data($channel, $keyword, 'cap-override'); - } else { - $self->{pbot}->{logger}->log("Ignoring cap-override of " . $self->{factoids}->get_data($channel, $keyword, 'cap-override') . " on unlocked factoid\n"); + unless ($self->{factoids}->get_data($channel, $keyword, 'no_keyword_override')) { + if ($command =~ s/\s*--keyword-override=([^ ]+)\s*//) { $stuff->{keyword_override} = $1; } } + + $stuff->{command} = $command; + $stuff->{aliased} = 1; + + $self->{pbot}->{logger} + ->log("[" . (defined $stuff->{from} ? $stuff->{from} : "stdin") . "] ($stuff->{nick}!$stuff->{user}\@$stuff->{host}) $trigger_name aliased to: $command\n"); + + if (defined $self->{factoids}->get_data($channel, $keyword, 'cap-override')) { + if ($self->{factoids}->get_data($channel, $keyword, 'locked')) { + $self->{pbot}->{logger}->log("Capability override set to " . $self->{factoids}->get_data($channel, $keyword, 'cap-override') . "\n"); + $stuff->{'cap-override'} = $self->{factoids}->get_data($channel, $keyword, 'cap-override'); + } else { + $self->{pbot}->{logger}->log("Ignoring cap-override of " . $self->{factoids}->get_data($channel, $keyword, 'cap-override') . " on unlocked factoid\n"); + } + } + + return $self->{pbot}->{interpreter}->interpret($stuff); } - return $self->{pbot}->{interpreter}->interpret($stuff); - } + $self->{pbot}->{logger} + ->log("(" . (defined $stuff->{from} ? $stuff->{from} : "(undef)") . "): $stuff->{nick}!$stuff->{user}\@$stuff->{host}: $trigger_name: action: \"$action\"\n"); - $self->{pbot}->{logger}->log("(" . (defined $stuff->{from} ? $stuff->{from} : "(undef)") . "): $stuff->{nick}!$stuff->{user}\@$stuff->{host}: $trigger_name: action: \"$action\"\n"); - - if ($self->{factoids}->get_data($channel, $keyword, 'enabled') == 0) { - $self->{pbot}->{logger}->log("$trigger_name disabled.\n"); - return "/msg $stuff->{nick} ${ref_from}$trigger_name is currently disabled."; - } - - unless ($self->{factoids}->exists($channel, $keyword, 'interpolate') and $self->{factoids}->get_data($channel, $keyword, 'interpolate') eq '0') { - my ($root_channel, $root_keyword) = $self->find_factoid($stuff->{ref_from} ? $stuff->{ref_from} : $stuff->{from}, $stuff->{root_keyword}, arguments => $stuff->{arguments}, exact_channel => 1); - if (not defined $root_channel or not defined $root_keyword) { - $root_channel = $channel; - $root_keyword = $keyword; + if ($self->{factoids}->get_data($channel, $keyword, 'enabled') == 0) { + $self->{pbot}->{logger}->log("$trigger_name disabled.\n"); + return "/msg $stuff->{nick} ${ref_from}$trigger_name is currently disabled."; } - if (not length $stuff->{keyword_override} and length $self->{factoids}->get_data($root_channel, $root_keyword, 'keyword_override')) { - $stuff->{keyword_override} = $self->{factoids}->get_data($root_channel, $root_keyword, 'keyword_override'); - } - $stuff->{action} = $action; - $action = $self->expand_factoid_vars($stuff); - if ($self->{factoids}->get_data($channel, $keyword, 'allow_empty_args')) { - $action = $self->expand_action_arguments($action, $stuff->{arguments}, ''); + unless ($self->{factoids}->exists($channel, $keyword, 'interpolate') and $self->{factoids}->get_data($channel, $keyword, 'interpolate') eq '0') { + my ($root_channel, $root_keyword) = + $self->find_factoid($stuff->{ref_from} ? $stuff->{ref_from} : $stuff->{from}, $stuff->{root_keyword}, arguments => $stuff->{arguments}, exact_channel => 1); + if (not defined $root_channel or not defined $root_keyword) { + $root_channel = $channel; + $root_keyword = $keyword; + } + if (not length $stuff->{keyword_override} and length $self->{factoids}->get_data($root_channel, $root_keyword, 'keyword_override')) { + $stuff->{keyword_override} = $self->{factoids}->get_data($root_channel, $root_keyword, 'keyword_override'); + } + $stuff->{action} = $action; + $action = $self->expand_factoid_vars($stuff); + + if ($self->{factoids}->get_data($channel, $keyword, 'allow_empty_args')) { $action = $self->expand_action_arguments($action, $stuff->{arguments}, ''); } + else { $action = $self->expand_action_arguments($action, $stuff->{arguments}, $stuff->{nick}); } + } + + return $action if $stuff->{special} eq 'code-factoid'; + + if ($self->{factoids}->get_data($channel, $keyword, 'type') eq 'module') { + my $preserve_whitespace = $self->{factoids}->get_data($channel, $keyword, 'preserve_whitespace'); + $preserve_whitespace = 0 if not defined $preserve_whitespace; + + $stuff->{preserve_whitespace} = $preserve_whitespace; + $stuff->{root_keyword} = $keyword unless defined $stuff->{root_keyword}; + $stuff->{root_channel} = $channel; + + my $result = $self->{pbot}->{modules}->execute_module($stuff); + if (length $result) { return $ref_from . $result; } + else { return ""; } + } elsif ($self->{factoids}->get_data($channel, $keyword, 'type') eq 'text') { + + # Don't allow user-custom /msg factoids, unless factoid triggered by admin + if ($action =~ m/^\/msg/i) { + my $admin = $self->{pbot}->{users}->loggedin_admin($stuff->{from}, "$stuff->{nick}!$stuff->{user}\@$stuff->{host}"); + if (not $admin) { + $self->{pbot}->{logger}->log("[ABUSE] Bad factoid (contains /msg): $action\n"); + return "You must be an admin to use /msg in a factoid."; + } + } + + if ($ref_from) { + if ($action =~ s/^\/say\s+/$ref_from/i || $action =~ s/^\/me\s+(.*)/\/me $1 $ref_from/i || $action =~ s/^\/msg\s+([^ ]+)/\/msg $1 $ref_from/i) { return $action; } + else { return $ref_from . "$trigger_name is $action"; } + } else { + if ($action =~ m/^\/(?:say|me|msg)/i) { return $action; } + else { return "/say $trigger_name is $action"; } + } + } elsif ($self->{factoids}->get_data($channel, $keyword, 'type') eq 'regex') { + my $result = eval { + my $string = "$stuff->{original_keyword}" . (defined $stuff->{arguments} ? " $stuff->{arguments}" : ""); + my $cmd; + if ($string =~ m/$keyword/i) { + $self->{pbot}->{logger}->log("[$string] matches [$keyword] - calling [" . $action . "$']\n"); + $cmd = $action . $'; + my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $before, $after) = ($1, $2, $3, $4, $5, $6, $7, $8, $9, $`, $'); + $cmd =~ s/\$1/$a/g; + $cmd =~ s/\$2/$b/g; + $cmd =~ s/\$3/$c/g; + $cmd =~ s/\$4/$d/g; + $cmd =~ s/\$5/$e/g; + $cmd =~ s/\$6/$f/g; + $cmd =~ s/\$7/$g/g; + $cmd =~ s/\$8/$h/g; + $cmd =~ s/\$9/$i/g; + $cmd =~ s/\$`/$before/g; + $cmd =~ s/\$'/$after/g; + $cmd =~ s/^\s+//; + $cmd =~ s/\s+$//; + } else { + $cmd = $action; + } + + $stuff->{command} = $cmd; + return $self->{pbot}->{interpreter}->interpret($stuff); + }; + + if ($@) { + $self->{pbot}->{logger}->log("Regex fail: $@\n"); + return ""; + } + + if (length $result) { return $ref_from . $result; } + else { return ""; } } else { - $action = $self->expand_action_arguments($action, $stuff->{arguments}, $stuff->{nick}); + $self->{pbot}->{logger}->log("($stuff->{from}): $stuff->{nick}!$stuff->{user}\@$stuff->{host}): Unknown command type for '$trigger_name'\n"); + return "/me blinks." . " $ref_from"; } - } - - return $action if $stuff->{special} eq 'code-factoid'; - - if ($self->{factoids}->get_data($channel, $keyword, 'type') eq 'module') { - my $preserve_whitespace = $self->{factoids}->get_data($channel, $keyword, 'preserve_whitespace'); - $preserve_whitespace = 0 if not defined $preserve_whitespace; - - $stuff->{preserve_whitespace} = $preserve_whitespace; - $stuff->{root_keyword} = $keyword unless defined $stuff->{root_keyword}; - $stuff->{root_channel} = $channel; - - my $result = $self->{pbot}->{modules}->execute_module($stuff); - if (length $result) { - return $ref_from . $result; - } else { - return ""; - } - } - elsif ($self->{factoids}->get_data($channel, $keyword, 'type') eq 'text') { - # Don't allow user-custom /msg factoids, unless factoid triggered by admin - if ($action =~ m/^\/msg/i) { - my $admin = $self->{pbot}->{users}->loggedin_admin($stuff->{from}, "$stuff->{nick}!$stuff->{user}\@$stuff->{host}"); - if (not $admin) { - $self->{pbot}->{logger}->log("[ABUSE] Bad factoid (contains /msg): $action\n"); - return "You must be an admin to use /msg in a factoid."; - } - } - - if ($ref_from) { - if ($action =~ s/^\/say\s+/$ref_from/i || $action =~ s/^\/me\s+(.*)/\/me $1 $ref_from/i - || $action =~ s/^\/msg\s+([^ ]+)/\/msg $1 $ref_from/i) { - return $action; - } else { - return $ref_from . "$trigger_name is $action"; - } - } else { - if ($action =~ m/^\/(?:say|me|msg)/i) { - return $action; - } else { - return "/say $trigger_name is $action"; - } - } - } elsif ($self->{factoids}->get_data($channel, $keyword, 'type') eq 'regex') { - my $result = eval { - my $string = "$stuff->{original_keyword}" . (defined $stuff->{arguments} ? " $stuff->{arguments}" : ""); - my $cmd; - if ($string =~ m/$keyword/i) { - $self->{pbot}->{logger}->log("[$string] matches [$keyword] - calling [" . $action . "$']\n"); - $cmd = $action . $'; - my ($a, $b, $c, $d, $e, $f, $g, $h, $i, $before, $after) = ($1, $2, $3, $4, $5, $6, $7, $8, $9, $`, $'); - $cmd =~ s/\$1/$a/g; - $cmd =~ s/\$2/$b/g; - $cmd =~ s/\$3/$c/g; - $cmd =~ s/\$4/$d/g; - $cmd =~ s/\$5/$e/g; - $cmd =~ s/\$6/$f/g; - $cmd =~ s/\$7/$g/g; - $cmd =~ s/\$8/$h/g; - $cmd =~ s/\$9/$i/g; - $cmd =~ s/\$`/$before/g; - $cmd =~ s/\$'/$after/g; - $cmd =~ s/^\s+//; - $cmd =~ s/\s+$//; - } else { - $cmd = $action; - } - - $stuff->{command} = $cmd; - return $self->{pbot}->{interpreter}->interpret($stuff); - }; - - if ($@) { - $self->{pbot}->{logger}->log("Regex fail: $@\n"); - return ""; - } - - if (length $result) { - return $ref_from . $result; - } else { - return ""; - } - } else { - $self->{pbot}->{logger}->log("($stuff->{from}): $stuff->{nick}!$stuff->{user}\@$stuff->{host}): Unknown command type for '$trigger_name'\n"); - return "/me blinks." . " $ref_from"; - } } 1; diff --git a/PBot/Functions.pm b/PBot/Functions.pm index 885f019a..d31645ad 100644 --- a/PBot/Functions.pm +++ b/PBot/Functions.pm @@ -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 [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 [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 [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 [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 "; - }; + $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 "; + }; - 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; diff --git a/PBot/HashObject.pm b/PBot/HashObject.pm index c9b29a6e..6330d84a 100644 --- a/PBot/HashObject.pm +++ b/PBot/HashObject.pm @@ -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 $/; - ; - }; - - $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 $/; + ; + }; + + $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; diff --git a/PBot/IRC.pm b/PBot/IRC.pm index e7bb093d..794ed0be 100644 --- a/PBot/IRC.pm +++ b/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__ diff --git a/PBot/IRC/Connection.pm b/PBot/IRC/Connection.pm index d53a2a6b..61886200 100644 --- a/PBot/IRC/Connection.pm +++ b/PBot/IRC/Connection.pm @@ -13,12 +13,12 @@ # # ##################################################################### -package PBot::IRC::Connection; # pragma_ 2011/21/01 +package PBot::IRC::Connection; # pragma_ 2011/21/01 use feature 'unicode_strings'; -use PBot::IRC::Event; # pragma_ 2011/21/01 -use PBot::IRC::DCC; # pragma_ 2011/21/01 +use PBot::IRC::Event; # pragma_ 2011/21/01 +use PBot::IRC::DCC; # pragma_ 2011/21/01 use IO::Socket; use IO::Socket::INET; use Symbol; @@ -30,33 +30,32 @@ use Encode; eval 'use Time::HiRes qw(time)'; if (!$@) { - sub time (); - use subs 'time'; - require Time::HiRes; - Time::HiRes->import('time'); + sub time (); + use subs 'time'; + require Time::HiRes; + Time::HiRes->import('time'); } use strict; use vars ( - '$AUTOLOAD', + '$AUTOLOAD', ); - # The names of the methods to be handled by &AUTOLOAD. my %autoloaded = ( - 'ircname' => undef, - 'port' => undef, - 'username' => undef, - 'socket' => undef, - 'verbose' => undef, - 'parent' => undef, - 'hostname' => undef, - 'pacing' => undef, - 'utf8' => undef, - 'ssl' => undef, - 'ssl_ca_path' => undef, - 'ssl_ca_file' => undef, + 'ircname' => undef, + 'port' => undef, + 'username' => undef, + 'socket' => undef, + 'verbose' => undef, + 'parent' => undef, + 'hostname' => undef, + 'pacing' => undef, + 'utf8' => undef, + 'ssl' => undef, + 'ssl_ca_path' => undef, + 'ssl_ca_file' => undef, ); # This hash will contain any global default handlers that the user specifies. @@ -65,43 +64,45 @@ my %_udef = (); # Creates a new IRC object and assigns some default attributes. sub new { - my $proto = shift; + my $proto = shift; - my $self = { # obvious defaults go here, rest are user-set - _debug => $_[0]->{_debug}, - _port => 6667, - # Evals are for non-UNIX machines, just to make sure. - _username => eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "japh", - _ircname => $ENV{IRCNAME} || eval { (getpwuid($>))[6] } || "Just Another Perl Hacker", - _nick => $ENV{IRCNICK} || eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "WankerBot", - _ignore => {}, - _handler => {}, - _verbose => 0, # Is this an OK default? - _parent => shift, - _frag => '', - _connected => 0, - _maxlinelen => 510, # The RFC says we shouldn't exceed this. - _lastsl => 0, - _pacing => 0, # no pacing by default - _ssl => 0, # no ssl by default - _ssl_ca_path => undef, - _ssl_ca_file => undef, - _utf8 => 0, - _format => { 'default' => "[%f:%t] %m <%d>", }, - }; + my $self = { # obvious defaults go here, rest are user-set + _debug => $_[0]->{_debug}, + _port => 6667, - bless $self, $proto; - # do any necessary initialization here - $self->connect(@_) if @_; + # Evals are for non-UNIX machines, just to make sure. + _username => eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "japh", + _ircname => $ENV{IRCNAME} || eval { (getpwuid($>))[6] } || "Just Another Perl Hacker", + _nick => $ENV{IRCNICK} || eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "WankerBot", + _ignore => {}, + _handler => {}, + _verbose => 0, # Is this an OK default? + _parent => shift, + _frag => '', + _connected => 0, + _maxlinelen => 510, # The RFC says we shouldn't exceed this. + _lastsl => 0, + _pacing => 0, # no pacing by default + _ssl => 0, # no ssl by default + _ssl_ca_path => undef, + _ssl_ca_file => undef, + _utf8 => 0, + _format => {'default' => "[%f:%t] %m <%d>",}, + }; - return $self; + bless $self, $proto; + + # do any necessary initialization here + $self->connect(@_) if @_; + + return $self; } # Takes care of the methods in %autoloaded # Sets specified attribute, or returns its value if called without args. sub AUTOLOAD { - my $self = @_; ## can't modify @_ for goto &name - my $class = ref $self; ## die here if !ref($self) ? + my $self = @_; ## can't modify @_ for goto &name + my $class = ref $self; ## die here if !ref($self) ? my $meth; # -- #perl was here! -- @@ -109,11 +110,9 @@ sub AUTOLOAD { # of fun. # =) - ($meth = $AUTOLOAD) =~ s/^.*:://; ## strip fully qualified portion + ($meth = $AUTOLOAD) =~ s/^.*:://; ## strip fully qualified portion - unless (exists $autoloaded{$meth}) { - croak "No method called \"$meth\" for $class object."; - } + unless (exists $autoloaded{$meth}) { croak "No method called \"$meth\" for $class object."; } eval < 0, "before" => 1, "after" => 2 ); + my ($self, $event, $ref, $rp, $hash_ref, $real_name) = @_; + my $ev; + my %define = ("replace" => 0, "before" => 1, "after" => 2); - unless (@_ >= 3) { - croak "Not enough arguments to $real_name()"; - } - unless (ref($ref) eq 'CODE') { - croak "Second argument of $real_name isn't a coderef"; - } + unless (@_ >= 3) { croak "Not enough arguments to $real_name()"; } + unless (ref($ref) eq 'CODE') { croak "Second argument of $real_name isn't a coderef"; } - # Translate REPLACE, BEFORE and AFTER. - if (not defined $rp) { - $rp = 0; - } elsif ($rp =~ /^\D/) { - $rp = $define{lc $rp} || 0; - } + # Translate REPLACE, BEFORE and AFTER. + if (not defined $rp) { $rp = 0; } + elsif ($rp =~ /^\D/) { $rp = $define{lc $rp} || 0; } - foreach $ev (ref $event eq "ARRAY" ? @{$event} : $event) { - # Translate numerics to names - if ($ev =~ /^\d/) { - $ev = PBot::IRC::Event->trans($ev); # pragma_ 2011/21/01 - unless ($ev) { - carp "Unknown event type in $real_name: $ev"; - return; - } + foreach $ev (ref $event eq "ARRAY" ? @{$event} : $event) { + + # Translate numerics to names + if ($ev =~ /^\d/) { + $ev = PBot::IRC::Event->trans($ev); # pragma_ 2011/21/01 + unless ($ev) { + carp "Unknown event type in $real_name: $ev"; + return; + } + } + + $hash_ref->{lc $ev} = [$ref, $rp]; } - - $hash_ref->{lc $ev} = [ $ref, $rp ]; - } - return 1; + return 1; } # This sub will assign a user's custom function to a particular event which @@ -185,33 +178,33 @@ sub _add_generic_handler { # 2 - Call this handler right after the default handler. # These can also be referred to by the #define-like strings in %define. sub add_global_handler { - my ($self, $event, $ref, $rp) = @_; - return $self->_add_generic_handler($event, $ref, $rp, \%_udef, 'add_global_handler'); + my ($self, $event, $ref, $rp) = @_; + return $self->_add_generic_handler($event, $ref, $rp, \%_udef, 'add_global_handler'); } # This sub will assign a user's custom function to a particular event which # this connection might receive. Same args as above. sub add_handler { - my ($self, $event, $ref, $rp) = @_; - return $self->_add_generic_handler($event, $ref, $rp, $self->{_handler}, 'add_handler'); + my ($self, $event, $ref, $rp) = @_; + return $self->_add_generic_handler($event, $ref, $rp, $self->{_handler}, 'add_handler'); } # Hooks every event we know about... sub add_default_handler { - my ($self, $ref, $rp) = @_; - foreach my $eventtype (keys(%PBot::IRC::Event::_names)) { # pragma_ 2011/21/01 - $self->_add_generic_handler($eventtype, $ref, $rp, $self->{_handler}, 'add_default_handler'); - } - return 1; + my ($self, $ref, $rp) = @_; + foreach my $eventtype (keys(%PBot::IRC::Event::_names)) { # pragma_ 2011/21/01 + $self->_add_generic_handler($eventtype, $ref, $rp, $self->{_handler}, 'add_default_handler'); + } + return 1; } # Why do I even bother writing subs this simple? Sends an ADMIN command. # Takes 1 optional arg: the name of the server you want to query. sub admin { - my $self = shift; # Thank goodness for AutoLoader, huh? - # Perhaps we'll finally use it soon. + my $self = shift; # Thank goodness for AutoLoader, huh? + # Perhaps we'll finally use it soon. - $self->sl("ADMIN" . ($_[0] ? " $_[0]" : "")); + $self->sl("ADMIN" . ($_[0] ? " $_[0]" : "")); } # Toggles away-ness with the server. Optionally takes an away message. @@ -223,125 +216,134 @@ sub away { # Attempts to connect to the specified IRC (server, port) with the specified # (nick, username, ircname). Will close current connection if already open. sub connect { - my $self = shift; - my ($password, $sock); + my $self = shift; + my ($password, $sock); - if (@_) { - my (%arg) = @_; + if (@_) { + my (%arg) = @_; - $self->hostname($arg{'LocalAddr'}) if exists $arg{'LocalAddr'}; - $password = $arg{'Password'} if exists $arg{'Password'}; - $self->nick($arg{'Nick'}) if exists $arg{'Nick'}; - $self->port($arg{'Port'}) if exists $arg{'Port'}; - $self->server($arg{'Server'}) if exists $arg{'Server'}; - $self->ircname($arg{'Ircname'}) if exists $arg{'Ircname'}; - $self->username($arg{'Username'}) if exists $arg{'Username'}; - $self->pacing($arg{'Pacing'}) if exists $arg{'Pacing'}; - $self->utf8($arg{'UTF8'}) if exists $arg{'UTF8'}; - $self->ssl($arg{'SSL'}) if exists $arg{'SSL'}; - $self->ssl_ca_path($arg{'SSL_ca_path'}) if exists $arg{'SSL_ca_path'}; - $self->ssl_ca_file($arg{'SSL_ca_file'}) if exists $arg{'SSL_ca_file'}; - } - - # Lots of error-checking claptrap first... - unless ($self->server) { - unless ($ENV{IRCSERVER}) { - croak "No server address specified in connect()"; + $self->hostname($arg{'LocalAddr'}) if exists $arg{'LocalAddr'}; + $password = $arg{'Password'} if exists $arg{'Password'}; + $self->nick($arg{'Nick'}) if exists $arg{'Nick'}; + $self->port($arg{'Port'}) if exists $arg{'Port'}; + $self->server($arg{'Server'}) if exists $arg{'Server'}; + $self->ircname($arg{'Ircname'}) if exists $arg{'Ircname'}; + $self->username($arg{'Username'}) if exists $arg{'Username'}; + $self->pacing($arg{'Pacing'}) if exists $arg{'Pacing'}; + $self->utf8($arg{'UTF8'}) if exists $arg{'UTF8'}; + $self->ssl($arg{'SSL'}) if exists $arg{'SSL'}; + $self->ssl_ca_path($arg{'SSL_ca_path'}) if exists $arg{'SSL_ca_path'}; + $self->ssl_ca_file($arg{'SSL_ca_file'}) if exists $arg{'SSL_ca_file'}; } - $self->server( $ENV{IRCSERVER} ); - } - unless ($self->nick) { - $self->nick($ENV{IRCNICK} || eval { scalar getpwuid($>) } - || $ENV{USER} || $ENV{LOGNAME} || "WankerBot"); - } - unless ($self->port) { - $self->port($ENV{IRCPORT} || 6667); - } - unless ($self->ircname) { - $self->ircname($ENV{IRCNAME} || eval { (getpwuid($>))[6] } - || "Just Another Perl Hacker"); - } - unless ($self->username) { - $self->username(eval { scalar getpwuid($>) } || $ENV{USER} - || $ENV{LOGNAME} || "japh"); - } - # Now for the socket stuff... - if ($self->connected) { - $self->quit("Changing servers"); - } + # Lots of error-checking claptrap first... + unless ($self->server) { + unless ($ENV{IRCSERVER}) { croak "No server address specified in connect()"; } + $self->server($ENV{IRCSERVER}); + } + unless ($self->nick) { + $self->nick($ENV{IRCNICK} || eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "WankerBot"); + } + unless ($self->port) { $self->port($ENV{IRCPORT} || 6667); } + unless ($self->ircname) { + $self->ircname($ENV{IRCNAME} || eval { (getpwuid($>))[6] } || "Just Another Perl Hacker"); + } + unless ($self->username) { + $self->username(eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "japh"); + } - if ($self->ssl) { - require IO::Socket::SSL; + # Now for the socket stuff... + if ($self->connected) { $self->quit("Changing servers"); } + + if ($self->ssl) { + require IO::Socket::SSL; + + if ($self->ssl_ca_file) { + $self->socket( + IO::Socket::SSL->new( + PeerAddr => $self->server, + PeerPort => $self->port, + Proto => "tcp", + LocalAddr => $self->hostname, + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, + SSL_ca_file => $self->ssl_ca_file, + ) + ); + } elsif ($self->ssl_ca_path) { + $self->socket( + IO::Socket::SSL->new( + PeerAddr => $self->server, + PeerPort => $self->port, + Proto => "tcp", + LocalAddr => $self->hostname, + SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, + SSL_ca_path => $self->ssl_ca_path, + ) + ); + } else { + $self->socket( + IO::Socket::SSL->new( + PeerAddr => $self->server, + PeerPort => $self->port, + Proto => "tcp", + LocalAddr => $self->hostname, + ) + ); + } - if ($self->ssl_ca_file) { - $self->socket(IO::Socket::SSL->new(PeerAddr => $self->server, - PeerPort => $self->port, - Proto => "tcp", - LocalAddr => $self->hostname, - SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, - SSL_ca_file => $self->ssl_ca_file, - )); - } elsif ($self->ssl_ca_path) { - $self->socket(IO::Socket::SSL->new(PeerAddr => $self->server, - PeerPort => $self->port, - Proto => "tcp", - LocalAddr => $self->hostname, - SSL_verify_mode => IO::Socket::SSL->SSL_VERIFY_PEER, - SSL_ca_path => $self->ssl_ca_path, - )); } else { - $self->socket(IO::Socket::SSL->new(PeerAddr => $self->server, - PeerPort => $self->port, - Proto => "tcp", - LocalAddr => $self->hostname, - )); + + $self->socket( + IO::Socket::INET->new( + PeerAddr => $self->server, + PeerPort => $self->port, + Proto => "tcp", + LocalAddr => $self->hostname, + ) + ); } - } else { + if (!$self->socket) { + carp( + sprintf "Can't connect to %s:%s!", + $self->server, $self->port + ); + $self->error(1); + return; + } - $self->socket(IO::Socket::INET->new(PeerAddr => $self->server, - PeerPort => $self->port, - Proto => "tcp", - LocalAddr => $self->hostname, - )); - } + # Send a PASS command if they specified a password. According to + # the RFC, we should do this as soon as we connect. + if (defined $password) { $self->sl("PASS $password"); } - if (!$self->socket) { - carp (sprintf "Can't connect to %s:%s!", - $self->server, $self->port); - $self->error(1); - return; - } + # Now, log in to the server... + unless ( + $self->sl('NICK ' . $self->nick()) and $self->sl( + sprintf( + "USER %s %s %s :%s", + $self->username(), + "foo.bar.com", + $self->server(), + $self->ircname() + ) + ) + ) + { + carp "Couldn't send introduction to server: $!"; + $self->error(1); + $! = "Couldn't send NICK/USER introduction to " . $self->server; + return; + } - # Send a PASS command if they specified a password. According to - # the RFC, we should do this as soon as we connect. - if (defined $password) { - $self->sl("PASS $password"); - } - - # Now, log in to the server... - unless ($self->sl('NICK ' . $self->nick()) and - $self->sl(sprintf("USER %s %s %s :%s", - $self->username(), - "foo.bar.com", - $self->server(), - $self->ircname()))) { - carp "Couldn't send introduction to server: $!"; - $self->error(1); - $! = "Couldn't send NICK/USER introduction to " . $self->server; - return; - } - - $self->{_connected} = 1; - $self->parent->addconn($self); + $self->{_connected} = 1; + $self->parent->addconn($self); } # Returns a boolean value based on the state of the object's socket. sub connected { - my $self = shift; + my $self = shift; - return ( $self->{_connected} and $self->socket() ); + return ($self->{_connected} and $self->socket()); } # Sends a CTCP request to some hapless victim(s). @@ -349,198 +351,177 @@ sub connected { # the nick or channel of the intended recipient(s) # Any further args are arguments to CLIENTINFO, ERRMSG, or ACTION. sub ctcp { - my ($self, $type, $target) = splice @_, 0, 3; - $type = uc $type; + my ($self, $type, $target) = splice @_, 0, 3; + $type = uc $type; - unless ($target) { - croak "Not enough arguments to ctcp()"; - } + unless ($target) { croak "Not enough arguments to ctcp()"; } - if ($type eq "PING") { - unless ($self->sl("PRIVMSG $target :\001PING " . int(time) . "\001")) { - carp "Socket error sending $type request in ctcp()"; - return; + if ($type eq "PING") { + unless ($self->sl("PRIVMSG $target :\001PING " . int(time) . "\001")) { + carp "Socket error sending $type request in ctcp()"; + return; + } + } elsif (($type eq "CLIENTINFO" or $type eq "ACTION") and @_) { + unless ($self->sl("PRIVMSG $target :\001$type " . CORE::join(" ", @_) . "\001")) { + carp "Socket error sending $type request in ctcp()"; + return; + } + } elsif ($type eq "ERRMSG") { + unless (@_) { + carp "Not enough arguments to $type in ctcp()"; + return; + } + unless ($self->sl("PRIVMSG $target :\001ERRMSG " . CORE::join(" ", @_) . "\001")) { + carp "Socket error sending $type request in ctcp()"; + return; + } + } else { + unless ($self->sl("PRIVMSG $target :\001$type " . CORE::join(" ", @_) . "\001")) { + carp "Socket error sending $type request in ctcp()"; + return; + } } - } elsif (($type eq "CLIENTINFO" or $type eq "ACTION") and @_) { - unless ($self->sl("PRIVMSG $target :\001$type " . - CORE::join(" ", @_) . "\001")) { - carp "Socket error sending $type request in ctcp()"; - return; - } - } elsif ($type eq "ERRMSG") { - unless (@_) { - carp "Not enough arguments to $type in ctcp()"; - return; - } - unless ($self->sl("PRIVMSG $target :\001ERRMSG " . - CORE::join(" ", @_) . "\001")) { - carp "Socket error sending $type request in ctcp()"; - return; - } - } else { - unless ($self->sl("PRIVMSG $target :\001$type " . - CORE::join(" ",@_) . "\001")) { - carp "Socket error sending $type request in ctcp()"; - return; - } - } } # Sends replies to CTCP queries. Simple enough, right? # Takes 2 args: the target person or channel to send a reply to # the text of the reply sub ctcp_reply { - my $self = shift; + my $self = shift; - $self->notice($_[0], "\001" . $_[1] . "\001"); + $self->notice($_[0], "\001" . $_[1] . "\001"); } - # 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; - if (@_) { - $self->{_debug} = $_[0]; - } - return $self->{_debug}; + my $self = shift; + if (@_) { $self->{_debug} = $_[0]; } + return $self->{_debug}; } - # Dequotes CTCP messages according to ctcp.spec. Nothing special. # Then it breaks them into their component parts in a flexible, ircII- # compatible manner. This is not quite as trivial. Oh, well. # Takes 1 arg: the line to be dequoted. sub dequote { - my $line = shift; - my ($order, @chunks) = (0, ()); # CHUNG! CHUNG! CHUNG! + my $line = shift; + my ($order, @chunks) = (0, ()); # CHUNG! CHUNG! CHUNG! - # Filter misplaced \001s before processing... (Thanks, Tom!) - substr($line, rindex($line, "\001"), 1) = '\\a' - unless ($line =~ tr/\001//) % 2 == 0; + # Filter misplaced \001s before processing... (Thanks, Tom!) + substr($line, rindex($line, "\001"), 1) = '\\a' unless ($line =~ tr/\001//) % 2 == 0; - # Thanks to Abigail (abigail@fnx.com) for this clever bit. - if (index($line, "\cP") >= 0) { # dequote low-level \n, \r, ^P, and \0. - my (%h) = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP"); - $line =~ s/\cP([nr0\cP])/$h{$1}/g; - } - $line =~ s/\\([^\\a])/$1/g; # dequote unnecessarily quoted characters. + # Thanks to Abigail (abigail@fnx.com) for this clever bit. + if (index($line, "\cP") >= 0) { # dequote low-level \n, \r, ^P, and \0. + my (%h) = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP"); + $line =~ s/\cP([nr0\cP])/$h{$1}/g; + } + $line =~ s/\\([^\\a])/$1/g; # dequote unnecessarily quoted characters. - # If true, it's in odd order... ctcp commands start with first chunk. - $order = 1 if index($line, "\001") == 0; - @chunks = map { s/\\\\/\\/g; $_ } (split /\cA/, $line); + # If true, it's in odd order... ctcp commands start with first chunk. + $order = 1 if index($line, "\001") == 0; + @chunks = map { s/\\\\/\\/g; $_ } (split /\cA/, $line); - return ($order, @chunks); + return ($order, @chunks); } # Standard destructor method for the GC routines. (HAHAHAH! DIE! DIE! DIE!) sub DESTROY { - my $self = shift; - $self->handler("destroy", "nobody will ever use this"); - $self->quit(); - # anything else? -} + my $self = shift; + $self->handler("destroy", "nobody will ever use this"); + $self->quit(); + # anything else? +} # Disconnects this Connection object cleanly from the server. # Takes at least 1 arg: the format and args parameters to Event->new(). sub disconnect { - my $self = shift; + my $self = shift; - $self->{_connected} = 0; - $self->parent->removeconn($self); - $self->socket( undef ); - $self->handler(PBot::IRC::Event->new( "disconnect", # pragma_ 2011/21/01 - $self->server, - '', - @_ )); + $self->{_connected} = 0; + $self->parent->removeconn($self); + $self->socket(undef); + $self->handler( + PBot::IRC::Event->new( + "disconnect", # pragma_ 2011/21/01 + $self->server, + '', + @_ + ) + ); } - # Tells IRC.pm if there was an error opening this connection. It's just # for sane error passing. # Takes 1 optional arg: the new value for $self->{'iserror'} sub error { - my $self = shift; + my $self = shift; - $self->{'iserror'} = $_[0] if @_; - return $self->{'iserror'}; + $self->{'iserror'} = $_[0] if @_; + return $self->{'iserror'}; } # Lets the user set or retrieve a format for a message of any sort. # Takes at least 1 arg: the event whose format you're inquiring about # (optional) the new format to use for this event sub format { - my ($self, $ev) = splice @_, 0, 2; + my ($self, $ev) = splice @_, 0, 2; - unless ($ev) { - croak "Not enough arguments to format()"; - } + unless ($ev) { croak "Not enough arguments to format()"; } - if (@_) { - $self->{'_format'}->{$ev} = $_[0]; - } else { - return ($self->{'_format'}->{$ev} || - $self->{'_format'}->{'default'}); - } + if (@_) { $self->{'_format'}->{$ev} = $_[0]; } + else { return ($self->{'_format'}->{$ev} || $self->{'_format'}->{'default'}); } } # Calls the appropriate handler function for a specified event. # Takes 2 args: the name of the event to handle # the arguments to the handler function sub handler { - my ($self, $event) = splice @_, 0, 2; + my ($self, $event) = splice @_, 0, 2; - unless (defined $event) { - croak 'Too few arguments to Connection->handler()'; - } + unless (defined $event) { croak 'Too few arguments to Connection->handler()'; } - # Get name of event. - my $ev; - if (ref $event) { - $ev = $event->type; - } elsif (defined $event) { - $ev = $event; - $event = PBot::IRC::Event->new($event, '', '', ''); # pragma_ 2011/21/01 - } else { - croak "Not enough arguments to handler()"; - } + # Get name of event. + my $ev; + if (ref $event) { $ev = $event->type; } + elsif (defined $event) { + $ev = $event; + $event = PBot::IRC::Event->new($event, '', '', ''); # pragma_ 2011/21/01 + } else { + croak "Not enough arguments to handler()"; + } - print STDERR "Trying to handle event '$ev'.\n" if $self->{_debug}; + print STDERR "Trying to handle event '$ev'.\n" if $self->{_debug}; + if ($self->{_debug}) { + use Data::Dumper; + print STDERR "ev: ", Dumper($ev), "\nevent: ", Dumper($event), "\n"; + } - if ($self->{_debug}) { - use Data::Dumper; - print STDERR "ev: ", Dumper($ev), "\nevent: ", Dumper($event), "\n"; - } + my $handler = undef; + if (exists $self->{_handler}->{$ev}) { $handler = $self->{_handler}->{$ev}; } + elsif (exists $_udef{$ev}) { $handler = $_udef{$ev}; } + else { return $self->_default($event, @_); } - my $handler = undef; - if (exists $self->{_handler}->{$ev}) { - $handler = $self->{_handler}->{$ev}; - } elsif (exists $_udef{$ev}) { - $handler = $_udef{$ev}; - } else { - return $self->_default($event, @_); - } + my ($code, $rp) = @{$handler}; - my ($code, $rp) = @{$handler}; + # If we have args left, try to call the handler. + if ($rp == 0) { # REPLACE + &$code($self, $event, @_); + } elsif ($rp == 1) { # BEFORE + &$code($self, $event, @_); + $self->_default($event, @_); + } elsif ($rp == 2) { # AFTER + $self->_default($event, @_); + &$code($self, $event, @_); + } else { + confess "Bad parameter passed to handler(): rp=$rp"; + } - # If we have args left, try to call the handler. - if ($rp == 0) { # REPLACE - &$code($self, $event, @_); - } elsif ($rp == 1) { # BEFORE - &$code($self, $event, @_); - $self->_default($event, @_); - } elsif ($rp == 2) { # AFTER - $self->_default($event, @_); - &$code($self, $event, @_); - } else { - confess "Bad parameter passed to handler(): rp=$rp"; - } + print STDERR "Handler for '$ev' called.\n" if $self->{_debug}; - print STDERR "Handler for '$ev' called.\n" if $self->{_debug}; - - return 1; + return 1; } # Lets a user set hostmasks to discard certain messages from, or (if called @@ -548,72 +529,57 @@ sub handler { # Takes 2 args: type of ignore (public, msg, ctcp, etc) # (optional) [mask(s) to be added to list of specified type] sub ignore { - my $self = shift; + my $self = shift; - unless (@_) { - croak "Not enough arguments to ignore()"; - } + unless (@_) { croak "Not enough arguments to ignore()"; } - if (@_ == 1) { - if (exists $self->{_ignore}->{$_[0]}) { - return @{ $self->{_ignore}->{$_[0]} }; - } else { - return (); + if (@_ == 1) { + if (exists $self->{_ignore}->{$_[0]}) { return @{$self->{_ignore}->{$_[0]}}; } + else { return (); } + } elsif (@_ > 1) { # code defensively, remember... + my $type = shift; + + # I moved this part further down as an Obsessive Efficiency + # Initiative. It shouldn't be a problem if I do _parse right... + # ... but those are famous last words, eh? + unless (grep { $_ eq $type } qw(public msg ctcp notice channel nick other all)) { + carp "$type isn't a valid type to ignore()"; + return; + } + + if (exists $self->{_ignore}->{$type}) { push @{$self->{_ignore}->{$type}}, @_; } + else { $self->{_ignore}->{$type} = [@_]; } } - } elsif (@_ > 1) { # code defensively, remember... - my $type = shift; - - # I moved this part further down as an Obsessive Efficiency - # Initiative. It shouldn't be a problem if I do _parse right... - # ... but those are famous last words, eh? - unless (grep {$_ eq $type} - qw(public msg ctcp notice channel nick other all)) { - carp "$type isn't a valid type to ignore()"; - return; - } - - if ( exists $self->{_ignore}->{$type} ) { - push @{$self->{_ignore}->{$type}}, @_; - } else { - $self->{_ignore}->{$type} = [ @_ ]; - } - } } - # Yet Another Ridiculously Simple Sub. Sends an INFO command. # Takes 1 optional arg: the name of the server to query. sub info { - my $self = shift; + my $self = shift; - $self->sl("INFO" . ($_[0] ? " $_[0]" : "")); + $self->sl("INFO" . ($_[0] ? " $_[0]" : "")); } - # Invites someone to an invite-only channel. Whoop. # Takes 2 args: the nick of the person to invite # the channel to invite them to. # I hate the syntax of this command... always seemed like a protocol flaw. sub invite { - my $self = shift; + my $self = shift; - unless (@_ > 1) { - croak "Not enough arguments to invite()"; - } + unless (@_ > 1) { croak "Not enough arguments to invite()"; } - $self->sl("INVITE $_[0] $_[1]"); + $self->sl("INVITE $_[0] $_[1]"); } # Checks if a particular nickname is in use. # Takes at least 1 arg: nickname(s) to look up. sub ison { - my $self = shift; + my $self = shift; - unless (@_) { - croak 'Not enough args to ison().'; - } + unless (@_) { croak 'Not enough args to ison().'; } - $self->sl("ISON " . CORE::join(" ", @_)); + $self->sl("ISON " . CORE::join(" ", @_)); } # Joins a channel on the current server if connected, eh?. @@ -621,18 +587,16 @@ sub ison { # Takes 2 args: name of channel to join # optional channel password, for +k channels sub join { - my $self = shift; + my $self = shift; - unless ( $self->connected ) { - carp "Can't join() -- not connected to a server"; - return; - } + unless ($self->connected) { + carp "Can't join() -- not connected to a server"; + return; + } - unless (@_) { - croak "Not enough arguments to join()"; - } + unless (@_) { croak "Not enough arguments to join()"; } - return $self->sl("JOIN $_[0]" . ($_[1] ? " $_[1]" : "")); + return $self->sl("JOIN $_[0]" . ($_[1] ? " $_[1]" : "")); } @@ -640,51 +604,48 @@ sub join { # the nick of the bastard in question # (optional) a parting comment to the departing bastard sub kick { - my $self = shift; + my $self = shift; - unless (@_ > 1) { - croak "Not enough arguments to kick()"; - } - return $self->sl("KICK $_[0] $_[1]" . ($_[2] ? " :$_[2]" : "")); + unless (@_ > 1) { croak "Not enough arguments to kick()"; } + return $self->sl("KICK $_[0] $_[1]" . ($_[2] ? " :$_[2]" : "")); } # Gets a list of all the servers that are linked to another visible server. # Takes 2 optional args: it's a bitch to describe, and I'm too tired right # now, so read the RFC. sub links { - my ($self) = (shift, undef); + my ($self) = (shift, undef); - $self->sl("LINKS" . (scalar(@_) ? " " . CORE::join(" ", @_[0,1]) : "")); + $self->sl("LINKS" . (scalar(@_) ? " " . CORE::join(" ", @_[0, 1]) : "")); } - # Requests a list of channels on the server, or a quick snapshot of the current # channel (the server returns channel name, # of users, and topic for each). sub list { - my $self = shift; + my $self = shift; - $self->sl("LIST " . CORE::join(",", @_)); + $self->sl("LIST " . CORE::join(",", @_)); } # Sends a request for some server/user stats. # Takes 1 optional arg: the name of a server to request the info from. sub lusers { - my $self = shift; + my $self = shift; - $self->sl("LUSERS" . ($_[0] ? " $_[0]" : "")); + $self->sl("LUSERS" . ($_[0] ? " $_[0]" : "")); } # Gets and/or sets the max line length. The value previous to the sub # call will be returned. # Takes 1 (optional) arg: the maximum line length (in bytes) sub maxlinelen { - my $self = shift; + my $self = shift; - my $ret = $self->{_maxlinelen}; + my $ret = $self->{_maxlinelen}; - $self->{_maxlinelen} = shift if @_; + $self->{_maxlinelen} = shift if @_; - return $ret; + return $ret; } # Sends an action to the channel/nick you specify. It's truly amazing how @@ -692,9 +653,9 @@ sub maxlinelen { # Takes 2 args: the channel or nick to bother with your witticism # the action to send (e.g., "weed-whacks billn's hand off.") sub me { - my $self = shift; + my $self = shift; - $self->ctcp("ACTION", $_[0], $_[1]); + $self->ctcp("ACTION", $_[0], $_[1]); } # Change channel and user modes (this one is easy... the handler is a bitch.) @@ -702,31 +663,29 @@ sub me { # (optional) the mode string (i.e., "-boo+i") # (optional) operands of the mode string (nicks, hostmasks, etc.) sub mode { - my $self = shift; + my $self = shift; - unless (@_ >= 1) { - croak "Not enough arguments to mode()"; - } - $self->sl("MODE $_[0] " . CORE::join(" ", @_[1..$#_])); + unless (@_ >= 1) { croak "Not enough arguments to mode()"; } + $self->sl("MODE $_[0] " . CORE::join(" ", @_[1 .. $#_])); } # Sends a MOTD command to a server. # Takes 1 optional arg: the server to query (defaults to current server) sub motd { - my $self = shift; + my $self = shift; - $self->sl("MOTD" . ($_[0] ? " $_[0]" : "")); + $self->sl("MOTD" . ($_[0] ? " $_[0]" : "")); } # Requests the list of users for a particular channel (or the entire net, if # you're a masochist). # Takes 1 or more optional args: name(s) of channel(s) to list the users from. sub names { - my $self = shift; + my $self = shift; - $self->sl("NAMES " . CORE::join(",", @_)); + $self->sl("NAMES " . CORE::join(",", @_)); -} # Was this the easiest sub in the world, or what? +} # Was this the easiest sub in the world, or what? # Creates and returns a DCC CHAT object, analogous to IRC.pm's newconn(). # Takes at least 1 arg: An Event object for the DCC CHAT request. @@ -738,21 +697,22 @@ sub names { # - The address to connect to # - The port to connect on sub new_chat { - my $self = shift; - my ($init, $nick, $address, $port); + my $self = shift; + my ($init, $nick, $address, $port); - if (ref($_[0]) =~ /Event/) { - # If it's from an Event object, we can't be initiating, right? - ($init, undef, undef, undef, $address, $port) = (0, $_[0]->args); - $nick = $_[0]->nick; + if (ref($_[0]) =~ /Event/) { - } elsif (ref($_[0]) eq "ARRAY") { - ($init, $nick, $address, $port) = @{$_[0]}; - } else { - ($init, $nick, $address, $port) = @_; - } + # If it's from an Event object, we can't be initiating, right? + ($init, undef, undef, undef, $address, $port) = (0, $_[0]->args); + $nick = $_[0]->nick; - PBot::IRC::DCC::CHAT->new($self, $init, $nick, $address, $port); # pragma_ 2011/21/01 + } elsif (ref($_[0]) eq "ARRAY") { + ($init, $nick, $address, $port) = @{$_[0]}; + } else { + ($init, $nick, $address, $port) = @_; + } + + PBot::IRC::DCC::CHAT->new($self, $init, $nick, $address, $port); # pragma_ 2011/21/01 } # Creates and returns a DCC GET object, analogous to IRC.pm's newconn(). @@ -770,33 +730,32 @@ sub new_chat { # If you wish to do a DCC RESUME, specify the offset in bytes that you # want to start downloading from as the last argument. sub new_get { - my $self = shift; - my ($nick, $name, $address, $port, $size, $offset, $handle); + my $self = shift; + my ($nick, $name, $address, $port, $size, $offset, $handle); - if (ref($_[0]) =~ /Event/) { - (undef, undef, $name, $address, $port, $size) = $_[0]->args; - $nick = $_[0]->nick; - $handle = $_[1] if defined $_[1]; - } elsif (ref($_[0]) eq "ARRAY") { - ($nick, $name, $address, $port, $size) = @{$_[0]}; - $handle = $_[1] if defined $_[1]; - } else { - ($nick, $name, $address, $port, $size, $handle) = @_; - } + if (ref($_[0]) =~ /Event/) { + (undef, undef, $name, $address, $port, $size) = $_[0]->args; + $nick = $_[0]->nick; + $handle = $_[1] if defined $_[1]; + } elsif (ref($_[0]) eq "ARRAY") { + ($nick, $name, $address, $port, $size) = @{$_[0]}; + $handle = $_[1] if defined $_[1]; + } else { + ($nick, $name, $address, $port, $size, $handle) = @_; + } - unless (defined $handle and ref $handle and - (ref $handle eq "GLOB" or $handle->can('print'))) - { - carp ("Filehandle argument to Connection->new_get() must be ". - "a glob reference or object"); - return; # is this behavior OK? - } + unless (defined $handle and ref $handle and (ref $handle eq "GLOB" or $handle->can('print'))) { + carp("Filehandle argument to Connection->new_get() must be " . "a glob reference or object"); + return; # is this behavior OK? + } - my $dcc = PBot::IRC::DCC::GET->new( $self, $nick, $address, $port, $size, # pragma_ 2011/21/01 - $name, $handle, $offset ); + my $dcc = PBot::IRC::DCC::GET->new( + $self, $nick, $address, $port, $size, # pragma_ 2011/21/01 + $name, $handle, $offset + ); - $self->parent->addconn($dcc) if $dcc; - return $dcc; + $self->parent->addconn($dcc) if $dcc; + return $dcc; } # Creates and returns a DCC SEND object, analogous to IRC.pm's newconn(). @@ -804,16 +763,13 @@ sub new_get { # The name of the file to send # (optional) The blocksize for the connection (default 1k) sub new_send { - my $self = shift; - my ($nick, $filename, $blocksize); + my $self = shift; + my ($nick, $filename, $blocksize); - if (ref($_[0]) eq "ARRAY") { - ($nick, $filename, $blocksize) = @{$_[0]}; - } else { - ($nick, $filename, $blocksize) = @_; - } + if (ref($_[0]) eq "ARRAY") { ($nick, $filename, $blocksize) = @{$_[0]}; } + else { ($nick, $filename, $blocksize) = @_; } - PBot::IRC::DCC::SEND->new($self, $nick, $filename, $blocksize); # pragma_ 2011/21/01 + PBot::IRC::DCC::SEND->new($self, $nick, $filename, $blocksize); # pragma_ 2011/21/01 } # Selects nick for this object or returns currently set nick. @@ -822,16 +778,14 @@ sub new_send { # automatically try to change nicks. # Takes 1 arg: the nick. (I bet you could have figured that out...) sub nick { - my $self = shift; + my $self = shift; - if (@_) { - $self->{'_nick'} = shift; - if ($self->connected) { - return $self->sl("NICK " . $self->{'_nick'}); + if (@_) { + $self->{'_nick'} = shift; + if ($self->connected) { return $self->sl("NICK " . $self->{'_nick'}); } + } else { + return $self->{'_nick'}; } - } else { - return $self->{'_nick'}; - } } # Sends a notice to a channel or person. @@ -841,93 +795,90 @@ sub nick { # attribute, but it doesn't try to protect against flooding. If you # give it too much info, the IRC server will kick you off! sub notice { - my ($self, $to) = splice @_, 0, 2; + my ($self, $to) = splice @_, 0, 2; - unless (@_) { - croak "Not enough arguments to notice()"; - } + unless (@_) { croak "Not enough arguments to notice()"; } - my ($buf, $length, $line) = (CORE::join("", @_), $self->{_maxlinelen}); + my ($buf, $length, $line) = (CORE::join("", @_), $self->{_maxlinelen}); - while (length($buf) > 0) { - ($line, $buf) = unpack("a$length a*", $buf); - $self->sl("NOTICE $to :$line"); - } + while (length($buf) > 0) { + ($line, $buf) = unpack("a$length a*", $buf); + $self->sl("NOTICE $to :$line"); + } } # Makes you an IRCop, if you supply the right username and password. # Takes 2 args: Operator's username # Operator's password sub oper { - my $self = shift; + my $self = shift; - unless (@_ > 1) { - croak "Not enough arguments to oper()"; - } + unless (@_ > 1) { croak "Not enough arguments to oper()"; } - $self->sl("OPER $_[0] $_[1]"); + $self->sl("OPER $_[0] $_[1]"); } # This function splits apart a raw server line into its component parts # (message, target, message type, CTCP data, etc...) and passes it to the # appropriate handler. Takes no args, really. sub parse { - my ($self) = shift; - my ($from, $type, $message, @stuff, $itype, $ev, @lines, $line); + my ($self) = shift; + my ($from, $type, $message, @stuff, $itype, $ev, @lines, $line); - if (defined ($self->ssl ? - $self->socket->read($line, 10240) : - $self->socket->recv($line, 10240, 0)) - and - (length($self->{_frag}) + length($line)) > 0) { - # grab any remnant from the last go and split into lines - my $chunk = $self->{_frag} . $line; - @lines = split /\012/, $chunk; + if (defined($self->ssl ? $self->socket->read($line, 10240) : $self->socket->recv($line, 10240, 0)) and (length($self->{_frag}) + length($line)) > 0) { - # if the last line was incomplete, pop it off the chunk and - # stick it back into the frag holder. - $self->{_frag} = (substr($chunk, -1) ne "\012" ? pop @lines : ''); + # grab any remnant from the last go and split into lines + my $chunk = $self->{_frag} . $line; + @lines = split /\012/, $chunk; - } 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... - $self->disconnect('error', 'Connection reset by peer'); - return; - } + # if the last line was incomplete, pop it off the chunk and + # stick it back into the frag holder. + $self->{_frag} = (substr($chunk, -1) ne "\012" ? pop @lines : ''); - PARSELOOP: foreach $line (@lines) { - if ($self->{_utf8}) { - utf8::decode($line); - } + } else { - # Clean the lint filter every 2 weeks... - $line =~ s/[\012\015]+$//; - next unless $line; + # 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->disconnect('error', 'Connection reset by peer'); + return; + } - print STDERR "<<< $line\n" if $self->{_debug}; + PARSELOOP: foreach $line (@lines) { + if ($self->{_utf8}) { utf8::decode($line); } - # Like the RFC says: "respond as quickly as possible..." - if ($line =~ /^PING/) { - $ev = (PBot::IRC::Event->new( "ping", # pragma_ 2011/21/01 - $self->server, - $self->nick, - "serverping", # FIXME? - substr($line, 5) - )); + # Clean the lint filter every 2 weeks... + $line =~ s/[\012\015]+$//; + next unless $line; - # Had to move this up front to avoid a particularly pernicious bug. - } elsif ($line =~ /^NOTICE/) { - $ev = PBot::IRC::Event->new( "snotice", # pragma_ 2011/21/01 - $self->server, - '', - 'server', - (split /:/, $line, 2)[1] ); + print STDERR "<<< $line\n" if $self->{_debug}; + # Like the RFC says: "respond as quickly as possible..." + if ($line =~ /^PING/) { + $ev = ( + PBot::IRC::Event->new( + "ping", # pragma_ 2011/21/01 + $self->server, + $self->nick, + "serverping", # FIXME? + substr($line, 5) + ) + ); - # Spurious backslashes are for the benefit of cperl-mode. - # Assumption: all non-numeric message types begin with a letter - } elsif ($line =~ /^:? + # Had to move this up front to avoid a particularly pernicious bug. + } elsif ($line =~ /^NOTICE/) { + $ev = PBot::IRC::Event->new( + "snotice", # pragma_ 2011/21/01 + $self->server, + '', + 'server', + (split /:/, $line, 2)[1] + ); + + # Spurious backslashes are for the benefit of cperl-mode. + # Assumption: all non-numeric message types begin with a letter + } elsif ( + $line =~ /^:? (?:[][}{\w\\\`^|\-]+? # The nick (valid nickname chars) ! # The nick-username separator .+? # The username @@ -936,184 +887,205 @@ sub parse { \s+ # Space between mask and message type [A-Za-z] # First char of message type [^\s:]+? # The rest of the message type - /x) # That ought to do it for now... - { - $line = substr $line, 1 if $line =~ /^:/; + /x + ) # That ought to do it for now... + { + $line = substr $line, 1 if $line =~ /^:/; - # Patch submitted for v.0.72 - # Fixes problems with IPv6 hostnames. - # ($from, $line) = split ":", $line, 2; - ($from, $line) = $line =~ /^(?:|)(\S+\s+[^:]+):?(.*)/; + # Patch submitted for v.0.72 + # Fixes problems with IPv6 hostnames. + # ($from, $line) = split ":", $line, 2; + ($from, $line) = $line =~ /^(?:|)(\S+\s+[^:]+):?(.*)/; - print STDERR "from: [$from], line: [$line]\n" if $self->{_debug}; + print STDERR "from: [$from], line: [$line]\n" if $self->{_debug}; - ($from, $type, @stuff) = split /\s+/, $from; - $type = lc $type; + ($from, $type, @stuff) = split /\s+/, $from; + $type = lc $type; - # fix splitting of IPv6 hostnames in modes -- pragma- 2013/07/30 - if ($type eq "mode" and $#stuff > -1 and length $line) { - my @other_stuff = split /\s+/, $line; - $stuff[$#stuff] .= ':' . shift @other_stuff; - push @stuff, @other_stuff; - $line = ""; - } + # fix splitting of IPv6 hostnames in modes -- pragma- 2013/07/30 + if ($type eq "mode" and $#stuff > -1 and length $line) { + my @other_stuff = split /\s+/, $line; + $stuff[$#stuff] .= ':' . shift @other_stuff; + push @stuff, @other_stuff; + $line = ""; + } - # This should be fairly intuitive... (cperl-mode sucks, though) + # This should be fairly intuitive... (cperl-mode sucks, though) - if (defined $line and index($line, "\001") >= 0) { - $itype = "ctcp"; - unless ($type eq "notice") { - $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg"); - } - } elsif ($type eq "privmsg") { - $itype = $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg"); - } elsif ($type eq "notice") { - $itype = "notice"; - } elsif ($type eq "join" or $type eq "part" or - $type eq "mode" or $type eq "topic" or - $type eq "kick") { - $itype = "channel"; - } elsif ($type eq "nick") { - $itype = "nick"; - } else { - $itype = "other"; - } + if (defined $line and index($line, "\001") >= 0) { + $itype = "ctcp"; + unless ($type eq "notice") { $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg"); } + } elsif ($type eq "privmsg") { + $itype = $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg"); + } elsif ($type eq "notice") { + $itype = "notice"; + } elsif ($type eq "join" or $type eq "part" or $type eq "mode" or $type eq "topic" or $type eq "kick") { + $itype = "channel"; + } elsif ($type eq "nick") { + $itype = "nick"; + } else { + $itype = "other"; + } - # This goes through the list of ignored addresses for this message - # type and drops out of the sub if it's from an ignored hostmask. + # This goes through the list of ignored addresses for this message + # type and drops out of the sub if it's from an ignored hostmask. - study $from; - foreach ( $self->ignore($itype), $self->ignore("all") ) { - $_ = quotemeta; s/\\\*/.*/g; - next PARSELOOP if $from =~ /$_/i; - } + study $from; + foreach ($self->ignore($itype), $self->ignore("all")) { + $_ = quotemeta; s/\\\*/.*/g; + next PARSELOOP if $from =~ /$_/i; + } - # It used to look a lot worse. Here was the original version... - # the optimization above was proposed by Silmaril, for which I am - # eternally grateful. (Mine still looks cooler, though. :) + # It used to look a lot worse. Here was the original version... + # the optimization above was proposed by Silmaril, for which I am + # eternally grateful. (Mine still looks cooler, though. :) - # return if grep { $_ = join('.*', split(/\\\*/, - # quotemeta($_))); /$from/ } - # ($self->ignore($type), $self->ignore("all")); + # return if grep { $_ = join('.*', split(/\\\*/, + # quotemeta($_))); /$from/ } + # ($self->ignore($type), $self->ignore("all")); - # Add $line to @stuff for the handlers - push @stuff, $line if defined $line; + # Add $line to @stuff for the handlers + push @stuff, $line if defined $line; - # Now ship it off to the appropriate handler and forget about it. - if ( $itype eq "ctcp" ) { # it's got CTCP in it! - $self->parse_ctcp($type, $from, $stuff[0], $line); - next; + # Now ship it off to the appropriate handler and forget about it. + if ($itype eq "ctcp") { # it's got CTCP in it! + $self->parse_ctcp($type, $from, $stuff[0], $line); + next; - } elsif ($type eq "public" or $type eq "msg" or - $type eq "notice" or $type eq "mode" or - $type eq "join" or $type eq "part" or - $type eq "topic" or $type eq "invite" or - $type eq "whoisaccount" or $type eq "cap") { + } elsif ($type eq "public" + or $type eq "msg" + or $type eq "notice" + or $type eq "mode" + or $type eq "join" + or $type eq "part" + or $type eq "topic" + or $type eq "invite" + or $type eq "whoisaccount" + or $type eq "cap") + { - $ev = PBot::IRC::Event->new( $type, # pragma_ 2011/21/01 - $from, - shift(@stuff), - $type, - @stuff, - ); - } elsif ($type eq "quit" or $type eq "nick" or $type eq "account") { + $ev = PBot::IRC::Event->new( + $type, # pragma_ 2011/21/01 + $from, + shift(@stuff), + $type, + @stuff, + ); + } elsif ($type eq "quit" or $type eq "nick" or $type eq "account") { - $ev = PBot::IRC::Event->new( $type, # pragma_ 2011/21/01 - $from, - $from, - $type, - @stuff, - ); - } elsif ($type eq "kick") { + $ev = PBot::IRC::Event->new( + $type, # pragma_ 2011/21/01 + $from, + $from, + $type, + @stuff, + ); + } elsif ($type eq "kick") { - $ev = PBot::IRC::Event->new( $type, # pragma_ 2011/21/01 - $from, - $stuff[1], - $type, - @stuff[0,2..$#stuff], - ); + $ev = PBot::IRC::Event->new( + $type, # pragma_ 2011/21/01 + $from, + $stuff[1], + $type, + @stuff[0, 2 .. $#stuff], + ); - } elsif ($type eq "kill") { - $ev = PBot::IRC::Event->new($type, # pragma_ 2011/21/01 - $from, - '', - $type, - $line); # Ahh, what the hell. - } elsif ($type eq "wallops") { - $ev = PBot::IRC::Event->new($type, # pragma_ 2011/21/01 - $from, - '', - $type, - $line); - } elsif ($type eq "pong") { - $ev = PBot::IRC::Event->new($type, # pragma_ 2011/21/01 - $from, - '', - $type, - $line); - } else { - carp "Unknown event type: $type"; - } - } - elsif ($line =~ /^:? # Here's Ye Olde Numeric Handler! + } elsif ($type eq "kill") { + $ev = PBot::IRC::Event->new( + $type, # pragma_ 2011/21/01 + $from, + '', + $type, + $line + ); # Ahh, what the hell. + } elsif ($type eq "wallops") { + $ev = PBot::IRC::Event->new( + $type, # pragma_ 2011/21/01 + $from, + '', + $type, + $line + ); + } elsif ($type eq "pong") { + $ev = PBot::IRC::Event->new( + $type, # pragma_ 2011/21/01 + $from, + '', + $type, + $line + ); + } else { + carp "Unknown event type: $type"; + } + } elsif ( + $line =~ /^:? # Here's Ye Olde Numeric Handler! \S+? # the servername (can't assume RFC hostname) \s+? # Some spaces here... \d+? # The actual number - \b/x # Some other crap, whatever... - ) { - $ev = $self->parse_num($line); + \b/x # Some other crap, whatever... + ) + { + $ev = $self->parse_num($line); - } elsif ($line =~ /^:(\w+) MODE \1 /) { - $ev = PBot::IRC::Event->new( 'umode', # pragma_ 2011/21/01 - $self->server, - $self->nick, - 'server', - substr($line, index($line, ':', 1) + 1)); + } elsif ($line =~ /^:(\w+) MODE \1 /) { + $ev = PBot::IRC::Event->new( + 'umode', # pragma_ 2011/21/01 + $self->server, + $self->nick, + 'server', + substr($line, index($line, ':', 1) + 1) + ); - } elsif ($line =~ /^:? # Here's Ye Olde Server Notice handler! + } elsif ( + $line =~ /^:? # Here's Ye Olde Server Notice handler! .+? # the servername (can't assume RFC hostname) \s+? # Some spaces here... NOTICE # The server notice - \b/x # Some other crap, whatever... - ) { - $ev = PBot::IRC::Event->new( 'snotice', # pragma_ 2011/21/01 - $self->server, - '', - 'server', - (split /\s+/, $line, 3)[2] ); + \b/x # Some other crap, whatever... + ) + { + $ev = PBot::IRC::Event->new( + 'snotice', # pragma_ 2011/21/01 + $self->server, + '', + 'server', + (split /\s+/, $line, 3)[2] + ); + } elsif ($line =~ /^ERROR/) { + if ($line =~ /^ERROR :Closing [Ll]ink/) { # is this compatible? - } elsif ($line =~ /^ERROR/) { - if ($line =~ /^ERROR :Closing [Ll]ink/) { # is this compatible? + $ev = 'done'; + $self->disconnect('error', ($line =~ /(.*)/)); - $ev = 'done'; - $self->disconnect( 'error', ($line =~ /(.*)/) ); + } else { + $ev = PBot::IRC::Event->new( + "error", # pragma_ 2011/21/01 + $self->server, + '', + 'error', + (split /:/, $line, 2)[1] + ); + } + } elsif ($line =~ /^Closing [Ll]ink/) { + $ev = 'done'; + $self->disconnect('error', ($line =~ /(.*)/)); - } else { - $ev = PBot::IRC::Event->new( "error", # pragma_ 2011/21/01 - $self->server, - '', - 'error', - (split /:/, $line, 2)[1]); - } - } elsif ($line =~ /^Closing [Ll]ink/) { - $ev = 'done'; - $self->disconnect( 'error', ($line =~ /(.*)/) ); + } - } + if ($ev) { - if ($ev) { + # We need to be able to fall through if the handler has + # already been called (i.e., from within disconnect()). - # We need to be able to fall through if the handler has - # already been called (i.e., from within disconnect()). + $self->handler($ev) unless $ev eq 'done'; - $self->handler($ev) unless $ev eq 'done'; + } else { - } else { - # If it gets down to here, it's some exception I forgot about. - carp "Funky parse case: $line\n"; - } - } + # If it gets down to here, it's some exception I forgot about. + carp "Funky parse case: $line\n"; + } + } } # The backend that parse() sends CTCP requests off to. Pay no attention @@ -1123,108 +1095,107 @@ sub parse { # the first bit of stuff # the line from the server. sub parse_ctcp { - my ($self, $type, $from, $stuff, $line) = @_; + my ($self, $type, $from, $stuff, $line) = @_; - my ($one, $two); - my ($odd, @foo) = (&dequote($line)); + my ($one, $two); + my ($odd, @foo) = (&dequote($line)); - while (($one, $two) = (splice @foo, 0, 2)) { + while (($one, $two) = (splice @foo, 0, 2)) { - ($one, $two) = ($two, $one) if $odd; + ($one, $two) = ($two, $one) if $odd; - my ($ctype) = $one =~ /^(\w+)\b/; - my $prefix = undef; - if ($type eq 'notice') { - $prefix = 'cr'; - } elsif ($type eq 'public' or - $type eq 'msg' ) { - $prefix = 'c'; - } else { - carp "Unknown CTCP type: $type"; - return; + my ($ctype) = $one =~ /^(\w+)\b/; + my $prefix = undef; + if ($type eq 'notice') { $prefix = 'cr'; } + elsif ($type eq 'public' or $type eq 'msg') { $prefix = 'c'; } + else { + carp "Unknown CTCP type: $type"; + return; + } + + if ($prefix) { + my $handler = $prefix . lc $ctype; # unit. value prob with $ctype + + $one =~ s/^$ctype //i; # strip the CTCP type off the args + $self->handler( + PBot::IRC::Event->new( + $handler, $from, $stuff, # pragma_ 2011/21/01 + $handler, $one + ) + ); + } + + $self->handler(PBot::IRC::Event->new($type, $from, $stuff, $type, $two)) # pragma_ 2011/21/01 + if $two; } - - if ($prefix) { - my $handler = $prefix . lc $ctype; # unit. value prob with $ctype - - $one =~ s/^$ctype //i; # strip the CTCP type off the args - $self->handler(PBot::IRC::Event->new( $handler, $from, $stuff, # pragma_ 2011/21/01 - $handler, $one )); - } - - $self->handler(PBot::IRC::Event->new($type, $from, $stuff, $type, $two)) # pragma_ 2011/21/01 - if $two; - } - return 1; + return 1; } # Does special-case parsing for numeric events. Separate from the rest of # parse() for clarity reasons (I can hear Tkil gasping in shock now. :-). # Takes 1 arg: the raw server line sub parse_num { - my ($self, $line) = @_; + my ($self, $line) = @_; - # Figlet protection? This seems to be a bit closer to the RFC than - # the original version, which doesn't seem to handle :trailers quite - # correctly. + # Figlet protection? This seems to be a bit closer to the RFC than + # the original version, which doesn't seem to handle :trailers quite + # correctly. - my ($from, $type, $stuff) = split(/\s+/, $line, 3); - my ($blip, $space, $other, @stuff); - while ($stuff) { - ($blip, $space, $other) = split(/(\s+)/, $stuff, 2); - $space = "" unless $space; - $other = "" unless $other; # Thanks to jack velte... - if ($blip =~ /^:/) { - push @stuff, $blip . $space . $other; - last; - } else { - push @stuff, $blip; - $stuff = $other; + my ($from, $type, $stuff) = split(/\s+/, $line, 3); + my ($blip, $space, $other, @stuff); + while ($stuff) { + ($blip, $space, $other) = split(/(\s+)/, $stuff, 2); + $space = "" unless $space; + $other = "" unless $other; # Thanks to jack velte... + if ($blip =~ /^:/) { + push @stuff, $blip . $space . $other; + last; + } else { + push @stuff, $blip; + $stuff = $other; + } } - } - $from = substr $from, 1 if $from =~ /^:/; + $from = substr $from, 1 if $from =~ /^:/; - return PBot::IRC::Event->new( $type, # pragma_ 2011/21/01 - $from, - '', - 'server', - @stuff ); + return PBot::IRC::Event->new( + $type, # pragma_ 2011/21/01 + $from, + '', + 'server', + @stuff + ); } # Helps you flee those hard-to-stand channels. # Takes at least one arg: name(s) of channel(s) to leave. sub part { - my $self = shift; + my $self = shift; - unless (@_) { - croak "No arguments provided to part()"; - } - $self->sl("PART " . CORE::join(",", @_)); # "A must!" + unless (@_) { croak "No arguments provided to part()"; } + $self->sl("PART " . CORE::join(",", @_)); # "A must!" } - # Tells what's on the other end of a connection. Returns a 2-element list # consisting of the name on the other end and the type of connection. # Takes no args. sub peer { - my $self = shift; + my $self = shift; - return ($self->server(), "IRC connection"); + return ($self->server(), "IRC connection"); } - # Prints a message to the defined error filehandle(s). # No further description should be necessary. sub printerr { - shift; - print STDERR @_, "\n"; + shift; + print STDERR @_, "\n"; } # Prints a message to the defined output filehandle(s). sub print { - shift; - print STDOUT @_, "\n"; + shift; + print STDOUT @_, "\n"; } # Sends a message to a channel or person. @@ -1235,73 +1206,66 @@ sub print { # attribute, but it doesn't try to protect against flooding. If you # give it too much info, the IRC server will kick you off! sub privmsg { - my ($self, $to) = splice @_, 0, 2; + my ($self, $to) = splice @_, 0, 2; - unless (@_) { - croak 'Not enough arguments to privmsg()'; - } + unless (@_) { croak 'Not enough arguments to privmsg()'; } - my $buf = CORE::join '', @_; - my $length = $self->{_maxlinelen} - 11 - length($to); - my $line; + my $buf = CORE::join '', @_; + my $length = $self->{_maxlinelen} - 11 - length($to); + my $line; - if (ref($to) =~ /^(GLOB|IO::Socket)/) { - while (length($buf) > 0) { - ($line, $buf) = unpack("a$length a*", $buf); - send($to, $line . "\012", 0); + if (ref($to) =~ /^(GLOB|IO::Socket)/) { + while (length($buf) > 0) { + ($line, $buf) = unpack("a$length a*", $buf); + send($to, $line . "\012", 0); + } + } else { + while (length($buf) > 0) { + ($line, $buf) = unpack("a$length a*", $buf); + if (ref $to eq 'ARRAY') { $self->sl("PRIVMSG ", CORE::join(',', @$to), " :$line"); } + else { $self->sl("PRIVMSG $to :$line"); } + } } - } else { - while (length($buf) > 0) { - ($line, $buf) = unpack("a$length a*", $buf); - if (ref $to eq 'ARRAY') { - $self->sl("PRIVMSG ", CORE::join(',', @$to), " :$line"); - } else { - $self->sl("PRIVMSG $to :$line"); - } - } - } } - # Closes connection to IRC server. (Corresponding function for /QUIT) # Takes 1 optional arg: parting message, defaults to "Leaving" by custom. sub quit { - my $self = shift; + my $self = shift; - # Do any user-defined stuff before leaving - $self->handler("leaving"); + # Do any user-defined stuff before leaving + $self->handler("leaving"); - unless ( $self->connected ) { return (1) } + unless ($self->connected) { return (1) } - # Why bother checking for sl() errors now, after all? :) - # We just send the QUIT command and leave. The server will respond with - # a "Closing link" message, and parse() will catch it, close the - # connection, and throw a "disconnect" event. Neat, huh? :-) + # Why bother checking for sl() errors now, after all? :) + # We just send the QUIT command and leave. The server will respond with + # a "Closing link" message, and parse() will catch it, close the + # connection, and throw a "disconnect" event. Neat, huh? :-) - $self->sl("QUIT :" . (defined $_[0] ? $_[0] : "Leaving")); + $self->sl("QUIT :" . (defined $_[0] ? $_[0] : "Leaving")); - # since the quit sends a line to the server, we need to flush the - # output queue to make sure it gets there so the disconnect - $self->parent->flush_output_queue(); + # since the quit sends a line to the server, we need to flush the + # output queue to make sure it gets there so the disconnect + $self->parent->flush_output_queue(); - return 1; + return 1; } # As per the RFC, ask the server to "re-read and process its configuration # file." Your server may or may not take additional arguments. Generally # requires IRCop status. sub rehash { - my $self = shift; - $self->sl("REHASH" . CORE::join(" ", @_)); + my $self = shift; + $self->sl("REHASH" . CORE::join(" ", @_)); } - # As per the RFC, "force a server restart itself." (Love that RFC.) # Takes no arguments. If it succeeds, you will likely be disconnected, # but I assume you already knew that. This sub is too simple... sub restart { - my $self = shift; - $self->sl("RESTART"); + my $self = shift; + $self->sl("RESTART"); } # Schedules an event to be executed after some length of time. @@ -1309,37 +1273,29 @@ sub restart { # a coderef to execute when time's up # Any extra args are passed as arguments to the user's coderef. sub schedule { - my $self = shift; - my $time = shift; - my $coderef = shift; + my $self = shift; + my $time = shift; + my $coderef = shift; - unless ($coderef) { - croak 'Not enough arguments to Connection->schedule()'; - } - unless (ref($coderef) eq 'CODE') { - croak 'Second argument to schedule() isn\'t a coderef'; - } + unless ($coderef) { croak 'Not enough arguments to Connection->schedule()'; } + unless (ref($coderef) eq 'CODE') { croak 'Second argument to schedule() isn\'t a coderef'; } - print STDERR "Scheduling event with time [$time]\n" if $self->{_debug}; - $time += time; - $self->parent->enqueue_scheduled_event($time, $coderef, $self, @_); + print STDERR "Scheduling event with time [$time]\n" if $self->{_debug}; + $time += time; + $self->parent->enqueue_scheduled_event($time, $coderef, $self, @_); } sub schedule_output_event { - my $self = shift; - my $time = shift; - my $coderef = shift; + my $self = shift; + my $time = shift; + my $coderef = shift; - unless ($coderef) { - croak 'Not enough arguments to Connection->schedule()'; - } - unless (ref($coderef) eq 'CODE') { - croak 'Second argument to schedule() isn\'t a coderef'; - } + unless ($coderef) { croak 'Not enough arguments to Connection->schedule()'; } + unless (ref($coderef) eq 'CODE') { croak 'Second argument to schedule() isn\'t a coderef'; } - print STDERR "Scheduling output event with time [$time] [$_[0]]\n" if $self->{_debug}; - $time += time; - $self->parent->enqueue_output_event($time, $coderef, $self, @_); + print STDERR "Scheduling output event with time [$time] [$_[0]]\n" if $self->{_debug}; + $time += time; + $self->parent->enqueue_output_event($time, $coderef, $self, @_); } # Lets J. Random IRCop connect one IRC server to another. How uninteresting. @@ -1348,299 +1304,255 @@ sub schedule_output_event { # (optional) the server to connect to arg #1. Used mainly by # servers to communicate with each other. sub sconnect { - my $self = shift; + my $self = shift; - unless (@_) { - croak "Not enough arguments to sconnect()"; - } - $self->sl("CONNECT " . CORE::join(" ", @_)); + unless (@_) { croak "Not enough arguments to sconnect()"; } + $self->sl("CONNECT " . CORE::join(" ", @_)); } # Sets/changes the IRC server which this instance should connect to. # Takes 1 arg: the name of the server (see below for possible syntaxes) # ((syntaxen? syntaxi? syntaces?)) sub server { - my ($self) = shift; + my ($self) = shift; - if (@_) { - # cases like "irc.server.com:6668" - if (index($_[0], ':') > 0) { - my ($serv, $port) = split /:/, $_[0]; - if ($port =~ /\D/) { - carp "$port is not a valid port number in server()"; - return; - } - $self->{_server} = $serv; - $self->port($port); + if (@_) { - # cases like ":6668" (buried treasure!) - } elsif (index($_[0], ':') == 0 and $_[0] =~ /^:(\d+)/) { - $self->port($1); + # cases like "irc.server.com:6668" + if (index($_[0], ':') > 0) { + my ($serv, $port) = split /:/, $_[0]; + if ($port =~ /\D/) { + carp "$port is not a valid port number in server()"; + return; + } + $self->{_server} = $serv; + $self->port($port); + + # cases like ":6668" (buried treasure!) + } elsif (index($_[0], ':') == 0 and $_[0] =~ /^:(\d+)/) { + $self->port($1); + + # cases like "irc.server.com" + } else { + $self->{_server} = shift; + } + return (1); - # cases like "irc.server.com" } else { - $self->{_server} = shift; + return $self->{_server}; } - return (1); - - } else { - return $self->{_server}; - } } - # sends a raw IRC line to the server, possibly with pacing sub sl { - my $self = shift; - my $line = CORE::join '', @_; + my $self = shift; + my $line = CORE::join '', @_; - unless (@_) { - croak "Not enough arguments to sl()"; - } + unless (@_) { croak "Not enough arguments to sl()"; } - if (! $self->pacing) { - return $self->sl_real($line); - } + if (!$self->pacing) { return $self->sl_real($line); } - if ($self->{_slcount} < 14) { - $self->{_slcount}++; - $self->{_lastsl} = time; - return $self->schedule_output_event(0, \&sl_real, $line); - } + if ($self->{_slcount} < 14) { + $self->{_slcount}++; + $self->{_lastsl} = time; + return $self->schedule_output_event(0, \&sl_real, $line); + } - # calculate how long to wait before sending this line - my $time = time; - if ($time - $self->{_lastsl} > $self->pacing) { - $self->{_lastsl} = $time; - } else { - $self->{_lastsl} += $self->pacing; - } + # calculate how long to wait before sending this line + my $time = time; + if ($time - $self->{_lastsl} > $self->pacing) { $self->{_lastsl} = $time; } + else { $self->{_lastsl} += $self->pacing; } - my $seconds = $self->{_lastsl} - $time; + my $seconds = $self->{_lastsl} - $time; - if ($seconds == 0) { - $self->{_slcount} = 0; - } + if ($seconds == 0) { $self->{_slcount} = 0; } - ### DEBUG DEBUG DEBUG - if ($self->{_debug}) { - print STDERR "S-> $seconds $line\n"; - } + ### DEBUG DEBUG DEBUG + if ($self->{_debug}) { print STDERR "S-> $seconds $line\n"; } - $self->schedule_output_event($seconds, \&sl_real, $line); + $self->schedule_output_event($seconds, \&sl_real, $line); } - # Sends a raw IRC line to the server. # Corresponds to the internal sirc function of the same name. # Takes 1 arg: string to send to server. (duh. :) sub sl_real { - my $self = shift; - my $line = shift; + my $self = shift; + my $line = shift; - unless ($line) { - croak "Not enough arguments to sl_real()"; - } + unless ($line) { croak "Not enough arguments to sl_real()"; } - ### DEBUG DEBUG DEBUG - if ($self->{_debug}) { - print STDERR ">>> $line\n"; - } + ### DEBUG DEBUG DEBUG + if ($self->{_debug}) { print STDERR ">>> $line\n"; } - return unless defined $self->socket; + return unless defined $self->socket; - if ($self->{_utf8}) { - $line = encode('UTF-8', $line); - } + if ($self->{_utf8}) { $line = encode('UTF-8', $line); } - my $rv = eval { - # RFC compliance can be kinda nice... - my $rv = $self->ssl ? - $self->socket->print("$line\015\012") : - $self->socket->send("$line\015\012", 0); - unless ($rv) { - $self->handler("sockerror"); - return; - } + my $rv = eval { + + # RFC compliance can be kinda nice... + my $rv = $self->ssl ? $self->socket->print("$line\015\012") : $self->socket->send("$line\015\012", 0); + unless ($rv) { + $self->handler("sockerror"); + return; + } + return $rv; + }; + + if ($@) { print "Attempt to send bad line: [$line]\n"; } return $rv; - }; - - if ($@) { - print "Attempt to send bad line: [$line]\n"; - } - return $rv; } # Tells any server that you're an oper on to disconnect from the IRC network. # Takes at least 1 arg: the name of the server to disconnect # (optional) a comment about why it was disconnected sub squit { - my $self = shift; + my $self = shift; - unless (@_) { - croak "Not enough arguments to squit()"; - } + unless (@_) { croak "Not enough arguments to squit()"; } - $self->sl("SQUIT $_[0]" . ($_[1] ? " :$_[1]" : "")); + $self->sl("SQUIT $_[0]" . ($_[1] ? " :$_[1]" : "")); } # Gets various server statistics for the specified host. # Takes at least 2 arg: the type of stats to request [chiklmouy] # (optional) the server to request from (default is current server) sub stats { - my $self = shift; + my $self = shift; - unless (@_) { - croak "Not enough arguments passed to stats()"; - } + unless (@_) { croak "Not enough arguments passed to stats()"; } - $self->sl("STATS $_[0]" . ($_[1] ? " $_[1]" : "")); + $self->sl("STATS $_[0]" . ($_[1] ? " $_[1]" : "")); } # If anyone still has SUMMON enabled, this will implement it for you. # If not, well...heh. Sorry. First arg mandatory: user to summon. # Second arg optional: a server name. sub summon { - my $self = shift; + my $self = shift; - unless (@_) { - croak "Not enough arguments passed to summon()"; - } + unless (@_) { croak "Not enough arguments passed to summon()"; } - $self->sl("SUMMON $_[0]" . ($_[1] ? " $_[1]" : "")); + $self->sl("SUMMON $_[0]" . ($_[1] ? " $_[1]" : "")); } # Requests timestamp from specified server. Easy enough, right? # Takes 1 optional arg: a server name/mask to query # renamed to not collide with things... -- aburke sub timestamp { - my ($self, $serv) = (shift, undef); + my ($self, $serv) = (shift, undef); - $self->sl("TIME" . ($_[0] ? " $_[0]" : "")); + $self->sl("TIME" . ($_[0] ? " $_[0]" : "")); } # Sends request for current topic, or changes it to something else lame. # Takes at least 1 arg: the channel whose topic you want to screw around with # (optional) the new topic you want to impress everyone with sub topic { - my $self = shift; + my $self = shift; - unless (@_) { - croak "Not enough arguments to topic()"; - } + unless (@_) { croak "Not enough arguments to topic()"; } - # Can you tell I've been reading the Nethack source too much? :) - $self->sl("TOPIC $_[0]" . ($_[1] ? " :$_[1]" : "")); + # Can you tell I've been reading the Nethack source too much? :) + $self->sl("TOPIC $_[0]" . ($_[1] ? " :$_[1]" : "")); } # Sends a trace request to the server. Whoop. # Take 1 optional arg: the server or nickname to trace. sub trace { - my $self = shift; + my $self = shift; - $self->sl("TRACE" . ($_[0] ? " $_[0]" : "")); + $self->sl("TRACE" . ($_[0] ? " $_[0]" : "")); } # This method submitted by Dave Schmitt . Thanks, Dave! sub unignore { - my $self = shift; + my $self = shift; - croak "Not enough arguments to unignore()" unless @_; + croak "Not enough arguments to unignore()" unless @_; - if (@_ == 1) { - if (exists $self->{_ignore}->{$_[0]}) { - return @{ $self->{_ignore}->{$_[0]} }; - } else { - return (); + if (@_ == 1) { + if (exists $self->{_ignore}->{$_[0]}) { return @{$self->{_ignore}->{$_[0]}}; } + else { return (); } + } elsif (@_ > 1) { # code defensively, remember... + my $type = shift; + + # I moved this part further down as an Obsessive Efficiency + # Initiative. It shouldn't be a problem if I do _parse right... + # ... but those are famous last words, eh? + unless (grep { $_ eq $type } qw(public msg ctcp notice channel nick other all)) { + carp "$type isn't a valid type to unignore()"; + return; + } + + if (exists $self->{_ignore}->{$type}) { + + # removes all specifed entries ala _Perl_Cookbook_ recipe 4.7 + my @temp = @{$self->{_ignore}->{$type}}; + @{$self->{_ignore}->{$type}} = (); + my %seen = (); + foreach my $item (@_) { $seen{$item} = 1 } + foreach my $item (@temp) { push(@{$self->{_ignore}->{$type}}, $item) unless ($seen{$item}); } + } else { + carp "no ignore entry for $type to remove"; + } } - } elsif (@_ > 1) { # code defensively, remember... - my $type = shift; - - # I moved this part further down as an Obsessive Efficiency - # Initiative. It shouldn't be a problem if I do _parse right... - # ... but those are famous last words, eh? - unless (grep {$_ eq $type} - qw(public msg ctcp notice channel nick other all)) { - carp "$type isn't a valid type to unignore()"; - return; - } - - if ( exists $self->{_ignore}->{$type} ) { - # removes all specifed entries ala _Perl_Cookbook_ recipe 4.7 - my @temp = @{$self->{_ignore}->{$type}}; - @{$self->{_ignore}->{$type}}= (); - my %seen = (); - foreach my $item (@_) { $seen{$item}=1 } - foreach my $item (@temp) { - push(@{$self->{_ignore}->{$type}}, $item) - unless ($seen{$item}); - } - } else { - carp "no ignore entry for $type to remove"; - } - } } - # Requests userhost info from the server. # Takes at least 1 arg: nickname(s) to look up. sub userhost { - my $self = shift; + my $self = shift; - unless (@_) { - croak 'Not enough args to userhost().'; - } + unless (@_) { croak 'Not enough args to userhost().'; } - $self->sl("USERHOST " . CORE::join (" ", @_)); + $self->sl("USERHOST " . CORE::join(" ", @_)); } # Sends a users request to the server, which may or may not listen to you. # Take 1 optional arg: the server to query. sub users { - my $self = shift; + my $self = shift; - $self->sl("USERS" . ($_[0] ? " $_[0]" : "")); + $self->sl("USERS" . ($_[0] ? " $_[0]" : "")); } # Asks the IRC server what version and revision of ircd it's running. Whoop. # Takes 1 optional arg: the server name/glob. (default is current server) sub version { - my $self = shift; + my $self = shift; - $self->sl("VERSION" . ($_[0] ? " $_[0]" : "")); + $self->sl("VERSION" . ($_[0] ? " $_[0]" : "")); } # Sends a message to all opers on the network. Hypothetically. # Takes 1 arg: the text to send. sub wallops { - my $self = shift; + my $self = shift; - unless ($_[0]) { - croak 'No arguments passed to wallops()'; - } + unless ($_[0]) { croak 'No arguments passed to wallops()'; } - $self->sl("WALLOPS :" . CORE::join("", @_)); + $self->sl("WALLOPS :" . CORE::join("", @_)); } # Asks the server about stuff, you know. Whatever. Pass the Fritos, dude. # Takes 2 optional args: the bit of stuff to ask about # an "o" (nobody ever uses this...) sub who { - my $self = shift; + my $self = shift; - # Obfuscation! - $self->sl("WHO" . (@_ ? " @_" : "")); + # Obfuscation! + $self->sl("WHO" . (@_ ? " @_" : "")); } # If you've gotten this far, you probably already know what this does. # Takes at least 1 arg: nickmasks or channels to /whois sub whois { - my $self = shift; + my $self = shift; - unless (@_) { - croak "Not enough arguments to whois()"; - } - return $self->sl("WHOIS " . CORE::join(",", @_)); + unless (@_) { croak "Not enough arguments to whois()"; } + return $self->sl("WHOIS " . CORE::join(",", @_)); } # Same as above, in the past tense. @@ -1648,45 +1560,37 @@ sub whois { # (optional) max number of hits to display # (optional) server or servermask to query sub whowas { - my $self = shift; + my $self = shift; - unless (@_) { - croak "Not enough arguments to whowas()"; - } - return $self->sl("WHOWAS $_[0]" . ($_[1] ? " $_[1]" : "") . - (($_[1] && $_[2]) ? " $_[2]" : "")); + unless (@_) { croak "Not enough arguments to whowas()"; } + return $self->sl("WHOWAS $_[0]" . ($_[1] ? " $_[1]" : "") . (($_[1] && $_[2]) ? " $_[2]" : "")); } # This sub executes the default action for an event with no user-defined # handlers. It's all in one sub so that we don't have to make a bunch of # separate anonymous subs stuffed in a hash. sub _default { - my ($self, $event) = @_; - my $verbose = $self->verbose; + my ($self, $event) = @_; + my $verbose = $self->verbose; - # Users should only see this if the programmer (me) fucked up. - unless ($event) { - croak "You EEEEEDIOT!!! Not enough args to _default()!"; - } + # Users should only see this if the programmer (me) fucked up. + unless ($event) { croak "You EEEEEDIOT!!! Not enough args to _default()!"; } - # Reply to PING from server as quickly as possible. - if ($event->type eq "ping") { - $self->sl("PONG " . (CORE::join ' ', $event->args)); + # Reply to PING from server as quickly as possible. + if ($event->type eq "ping") { + $self->sl("PONG " . (CORE::join ' ', $event->args)); - } elsif ($event->type eq "disconnect") { + } elsif ($event->type eq "disconnect") { - # I violate OO tenets. (It's consensual, of course.) - unless (keys %{$self->parent->{_connhash}} > 0) { - die "No active connections left, exiting...\n"; + # I violate OO tenets. (It's consensual, of course.) + unless (keys %{$self->parent->{_connhash}} > 0) { die "No active connections left, exiting...\n"; } } - } - return 1; + return 1; } 1; - __END__ =head1 NAME diff --git a/PBot/IRC/DCC.pm b/PBot/IRC/DCC.pm index a8067e9f..e123fa43 100644 --- a/PBot/IRC/DCC.pm +++ b/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 diff --git a/PBot/IRC/Event.pm b/PBot/IRC/Event.pm index 56085e0e..71fd4126 100644 --- a/PBot/IRC/Event.pm +++ b/PBot/IRC/Event.pm @@ -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 - 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 - 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 - 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 + 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 + 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 + 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 diff --git a/PBot/IRC/EventQueue.pm b/PBot/IRC/EventQueue.pm index 04a645ec..e3bf1a96 100644 --- a/PBot/IRC/EventQueue.pm +++ b/PBot/IRC/EventQueue.pm @@ -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; diff --git a/PBot/IRC/EventQueue/Entry.pm b/PBot/IRC/EventQueue/Entry.pm index 66ace8b1..10381fcf 100644 --- a/PBot/IRC/EventQueue/Entry.pm +++ b/PBot/IRC/EventQueue/Entry.pm @@ -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; diff --git a/PBot/IRCHandlers.pm b/PBot/IRCHandlers.pm index 32240de8..5e262269 100644 --- a/PBot/IRCHandlers.pm +++ b/PBot/IRCHandlers.pm @@ -8,6 +8,7 @@ # file, You can obtain one at http://mozilla.org/MPL/2.0/. package PBot::IRCHandlers; + use parent 'PBot::Class'; use warnings; use strict; @@ -15,579 +16,572 @@ use feature 'unicode_strings'; use Time::HiRes qw(gettimeofday); use Data::Dumper; + $Data::Dumper::Sortkeys = 1; sub initialize { - my ($self, %conf) = @_; - $self->{pbot}->{event_dispatcher}->register_handler('irc.welcome', sub { $self->on_connect(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.disconnect', sub { $self->on_disconnect(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.motd', sub { $self->on_motd(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.notice', sub { $self->on_notice(@_) }); - $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.msg', sub { $self->on_msg(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.mode', sub { $self->on_mode(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.part', sub { $self->on_departure(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.join', sub { $self->on_join(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.kick', sub { $self->on_kick(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.quit', sub { $self->on_departure(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.nick', sub { $self->on_nickchange(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.nicknameinuse', sub { $self->on_nicknameinuse(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.invite', sub { $self->on_invite(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.cap', sub { $self->on_cap(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.map', sub { $self->on_map(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.whoreply', sub { $self->on_whoreply(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.whospcrpl', sub { $self->on_whospcrpl(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.endofwho', sub { $self->on_endofwho(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.channelmodeis', sub { $self->on_channelmodeis(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.topic', sub { $self->on_topic(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.topicinfo', sub { $self->on_topicinfo(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('irc.channelcreate', sub { $self->on_channelcreate(@_) }); + my ($self, %conf) = @_; + $self->{pbot}->{event_dispatcher}->register_handler('irc.welcome', sub { $self->on_connect(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.disconnect', sub { $self->on_disconnect(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.motd', sub { $self->on_motd(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.notice', sub { $self->on_notice(@_) }); + $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.msg', sub { $self->on_msg(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.mode', sub { $self->on_mode(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.part', sub { $self->on_departure(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.join', sub { $self->on_join(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.kick', sub { $self->on_kick(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.quit', sub { $self->on_departure(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.nick', sub { $self->on_nickchange(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.nicknameinuse', sub { $self->on_nicknameinuse(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.invite', sub { $self->on_invite(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.cap', sub { $self->on_cap(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.map', sub { $self->on_map(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.whoreply', sub { $self->on_whoreply(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.whospcrpl', sub { $self->on_whospcrpl(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.endofwho', sub { $self->on_endofwho(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.channelmodeis', sub { $self->on_channelmodeis(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.topic', sub { $self->on_topic(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.topicinfo', sub { $self->on_topicinfo(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.channelcreate', sub { $self->on_channelcreate(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('pbot.join', sub { $self->on_self_join(@_) }); - $self->{pbot}->{event_dispatcher}->register_handler('pbot.part', sub { $self->on_self_part(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('pbot.join', sub { $self->on_self_join(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('pbot.part', sub { $self->on_self_part(@_) }); - $self->{pbot}->{timer}->register(sub { $self->check_pending_whos }, 10); + $self->{pbot}->{timer}->register(sub { $self->check_pending_whos }, 10); } sub default_handler { - my ($self, $conn, $event) = @_; + my ($self, $conn, $event) = @_; - if (not defined $self->{pbot}->{event_dispatcher}->dispatch_event("irc.$event->{type}", { conn => $conn, event => $event })) { - if ($self->{pbot}->{registry}->get_value('irc', 'log_default_handler')) { - $self->{pbot}->{logger}->log(Dumper $event); + if (not defined $self->{pbot}->{event_dispatcher}->dispatch_event("irc.$event->{type}", {conn => $conn, event => $event})) { + if ($self->{pbot}->{registry}->get_value('irc', 'log_default_handler')) { $self->{pbot}->{logger}->log(Dumper $event); } } - } } sub on_init { - my ($self, $conn, $event) = @_; - my (@args) = ($event->args); - shift (@args); - $self->{pbot}->{logger}->log("*** @args\n"); + my ($self, $conn, $event) = @_; + my (@args) = ($event->args); + shift(@args); + $self->{pbot}->{logger}->log("*** @args\n"); } sub on_connect { - my ($self, $event_type, $event) = @_; - $self->{pbot}->{logger}->log("Connected!\n"); - $event->{conn}->{connected} = 1; + my ($self, $event_type, $event) = @_; + $self->{pbot}->{logger}->log("Connected!\n"); + $event->{conn}->{connected} = 1; - $self->{pbot}->{logger}->log("Requesting account-notify and extended-join . . .\n"); - $event->{conn}->sl("CAP REQ :account-notify extended-join"); + $self->{pbot}->{logger}->log("Requesting account-notify and extended-join . . .\n"); + $event->{conn}->sl("CAP REQ :account-notify extended-join"); - if (length $self->{pbot}->{registry}->get_value('irc', 'identify_password')) { - $self->{pbot}->{logger}->log("Identifying with NickServ . . .\n"); + if (length $self->{pbot}->{registry}->get_value('irc', 'identify_password')) { + $self->{pbot}->{logger}->log("Identifying with NickServ . . .\n"); - my $nickserv = $self->{pbot}->{registry}->get_value('general', 'identify_nick') // 'nickserv'; - my $command = $self->{pbot}->{registry}->get_value('general', 'identify_command') // 'identify $nick $password'; + my $nickserv = $self->{pbot}->{registry}->get_value('general', 'identify_nick') // 'nickserv'; + my $command = $self->{pbot}->{registry}->get_value('general', 'identify_command') // 'identify $nick $password'; - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - my $password = $self->{pbot}->{registry}->get_value('irc', 'identify_password'); + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + my $password = $self->{pbot}->{registry}->get_value('irc', 'identify_password'); - $command =~ s/\$nick\b/$botnick/g; - $command =~ s/\$password\b/$password/g; + $command =~ s/\$nick\b/$botnick/g; + $command =~ s/\$password\b/$password/g; - $event->{conn}->privmsg($nickserv, $command); - } else { - $self->{pbot}->{logger}->log("No identify password; skipping identification to services.\n"); - } + $event->{conn}->privmsg($nickserv, $command); + } else { + $self->{pbot}->{logger}->log("No identify password; skipping identification to services.\n"); + } - if (not $self->{pbot}->{registry}->get_value('general', 'autojoin_wait_for_nickserv')) { - $self->{pbot}->{logger}->log("Autojoining channels immediately; to wait for services set general.autojoin_wait_for_nickserv to 1.\n"); - $self->{pbot}->{channels}->autojoin; - } else { - $self->{pbot}->{logger}->log("Waiting for services identify response before autojoining channels.\n"); - } + if (not $self->{pbot}->{registry}->get_value('general', 'autojoin_wait_for_nickserv')) { + $self->{pbot}->{logger}->log("Autojoining channels immediately; to wait for services set general.autojoin_wait_for_nickserv to 1.\n"); + $self->{pbot}->{channels}->autojoin; + } else { + $self->{pbot}->{logger}->log("Waiting for services identify response before autojoining channels.\n"); + } - return 0; + return 0; } sub on_disconnect { - my ($self, $event_type, $event) = @_; - $self->{pbot}->{logger}->log("Disconnected...\n"); - $self->{pbot}->{connected} = 0; - return 0; + my ($self, $event_type, $event) = @_; + $self->{pbot}->{logger}->log("Disconnected...\n"); + $self->{pbot}->{connected} = 0; + return 0; } sub on_motd { - my ($self, $event_type, $event) = @_; + my ($self, $event_type, $event) = @_; - if ($self->{pbot}->{registry}->get_value('irc', 'show_motd')) { - my $server = $event->{event}->{from}; - my $msg = $event->{event}->{args}[1]; - $self->{pbot}->{logger}->log("MOTD from $server :: $msg\n"); - } - return 0; + if ($self->{pbot}->{registry}->get_value('irc', 'show_motd')) { + my $server = $event->{event}->{from}; + my $msg = $event->{event}->{args}[1]; + $self->{pbot}->{logger}->log("MOTD from $server :: $msg\n"); + } + return 0; } sub on_self_join { - my ($self, $event_type, $event) = @_; - my $send_who = $self->{pbot}->{registry}->get_value('general', 'send_who_on_join') // 1; - $self->send_who($event->{channel}) if $send_who; - return 0; + my ($self, $event_type, $event) = @_; + my $send_who = $self->{pbot}->{registry}->get_value('general', 'send_who_on_join') // 1; + $self->send_who($event->{channel}) if $send_who; + return 0; } sub on_self_part { - my ($self, $event_type, $event) = @_; - return 0; + my ($self, $event_type, $event) = @_; + return 0; } sub on_public { - my ($self, $event_type, $event) = @_; - my $from = $event->{event}->{to}[0]; - my $nick = $event->{event}->nick; - my $user = $event->{event}->user; - my $host = $event->{event}->host; - my $text = $event->{event}->{args}[0]; + my ($self, $event_type, $event) = @_; - ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); + my $from = $event->{event}->{to}[0]; + my $nick = $event->{event}->nick; + my $user = $event->{event}->user; + my $host = $event->{event}->host; + my $text = $event->{event}->{args}[0]; - $event->{interpreted} = $self->{pbot}->{interpreter}->process_line($from, $nick, $user, $host, $text); - return 0; + ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); + + $event->{interpreted} = $self->{pbot}->{interpreter}->process_line($from, $nick, $user, $host, $text); + return 0; } sub on_msg { - my ($self, $event_type, $event) = @_; - my ($nick, $host) = ($event->{event}->nick, $event->{event}->host); - my $text = $event->{event}->{args}[0]; - my $bot_trigger = $self->{pbot}->{registry}->get_value('general', 'trigger'); - my $bot_nick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + my ($self, $event_type, $event) = @_; + my ($nick, $host) = ($event->{event}->nick, $event->{event}->host); + my $text = $event->{event}->{args}[0]; - $text =~ s/^$bot_trigger?\s*(.*)/$bot_nick $1/; - $event->{event}->{to}[0] = $nick; - $event->{event}->{args}[0] = $text; - $self->on_public($event_type, $event); - return 0; + my $bot_trigger = $self->{pbot}->{registry}->get_value('general', 'trigger'); + my $bot_nick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + + $text =~ s/^$bot_trigger?\s*(.*)/$bot_nick $1/; + $event->{event}->{to}[0] = $nick; + $event->{event}->{args}[0] = $text; + $self->on_public($event_type, $event); + return 0; } sub on_notice { - my ($self, $event_type, $event) = @_; - my ($nick, $user, $host) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host); - my $text = $event->{event}->{args}[0]; + my ($self, $event_type, $event) = @_; + my ($nick, $user, $host) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host); + my $text = $event->{event}->{args}[0]; - $self->{pbot}->{logger}->log("Received NOTICE from $nick!$user\@$host to $event->{event}->{to}[0] '$text'\n"); + $self->{pbot}->{logger}->log("Received NOTICE from $nick!$user\@$host to $event->{event}->{to}[0] '$text'\n"); - return 0 if not length $host; + return 0 if not length $host; - if ($nick eq 'NickServ') { - if ($text =~ m/This nickname is registered/) { - if (length $self->{pbot}->{registry}->get_value('irc', 'identify_password')) { - $self->{pbot}->{logger}->log("Identifying with NickServ . . .\n"); - $event->{conn}->privmsg("nickserv", "identify " . $self->{pbot}->{registry}->get_value('irc', 'identify_password')); - } - } elsif ($text =~ m/You are now identified/) { - if ($self->{pbot}->{registry}->get_value('irc', 'randomize_nick')) { - $event->{conn}->nick($self->{pbot}->{registry}->get_value('irc', 'botnick')); - } else { - $self->{pbot}->{channels}->autojoin; - } - } elsif ($text =~ m/has been ghosted/) { - $event->{conn}->nick($self->{pbot}->{registry}->get_value('irc', 'botnick')); + if ($nick eq 'NickServ') { + if ($text =~ m/This nickname is registered/) { + if (length $self->{pbot}->{registry}->get_value('irc', 'identify_password')) { + $self->{pbot}->{logger}->log("Identifying with NickServ . . .\n"); + $event->{conn}->privmsg("nickserv", "identify " . $self->{pbot}->{registry}->get_value('irc', 'identify_password')); + } + } elsif ($text =~ m/You are now identified/) { + if ($self->{pbot}->{registry}->get_value('irc', 'randomize_nick')) { $event->{conn}->nick($self->{pbot}->{registry}->get_value('irc', 'botnick')); } + else { $self->{pbot}->{channels}->autojoin; } + } elsif ($text =~ m/has been ghosted/) { + $event->{conn}->nick($self->{pbot}->{registry}->get_value('irc', 'botnick')); + } + } else { + if ($event->{event}->{to}[0] eq $self->{pbot}->{registry}->get_value('irc', 'botnick')) { $event->{event}->{to}[0] = $nick; } + $self->on_public($event_type, $event); } - } else { - if ($event->{event}->{to}[0] eq $self->{pbot}->{registry}->get_value('irc', 'botnick')) { - $event->{event}->{to}[0] = $nick; - } - $self->on_public($event_type, $event); - } - return 0; + return 0; } sub on_action { - my ($self, $event_type, $event) = @_; + my ($self, $event_type, $event) = @_; - $event->{event}->{args}[0] = "/me " . $event->{event}->{args}[0]; + $event->{event}->{args}[0] = "/me " . $event->{event}->{args}[0]; - $self->on_public($event_type, $event); - return 0; + $self->on_public($event_type, $event); + return 0; } # FIXME: on_mode doesn't handle chanmodes that have parameters, e.g. +l sub on_mode { - my ($self, $event_type, $event) = @_; - my ($nick, $user, $host) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host); - my $mode_string = $event->{event}->{args}[0]; - my $channel = $event->{event}->{to}[0]; - $channel = lc $channel; + my ($self, $event_type, $event) = @_; + my ($nick, $user, $host) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host); + my $mode_string = $event->{event}->{args}[0]; + my $channel = $event->{event}->{to}[0]; + $channel = lc $channel; - ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); + ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); - my ($mode, $mode_char, $modifier); - my $i = 0; - my $target; + my ($mode, $mode_char, $modifier); + my $i = 0; + my $target; - while ($mode_string =~ m/(.)/g) { - my $char = $1; + while ($mode_string =~ m/(.)/g) { + my $char = $1; - if ($char eq '-' or $char eq '+') { - $modifier = $char; - next; - } + if ($char eq '-' or $char eq '+') { + $modifier = $char; + next; + } - $mode = $modifier . $char; - $mode_char = $char; - $target = $event->{event}->{args}[++$i]; + $mode = $modifier . $char; + $mode_char = $char; + $target = $event->{event}->{args}[++$i]; - $self->{pbot}->{logger}->log("Mode $channel [$mode" . (length $target ? " $target" : '') . "] by $nick!$user\@$host\n"); + $self->{pbot}->{logger}->log("Mode $channel [$mode" . (length $target ? " $target" : '') . "] by $nick!$user\@$host\n"); - if ($mode eq "-b" or $mode eq "+b" or $mode eq "-q" or $mode eq "+q") { - $self->{pbot}->{bantracker}->track_mode("$nick!$user\@$host", $mode, $target, $channel); - } + if ($mode eq "-b" or $mode eq "+b" or $mode eq "-q" or $mode eq "+q") { $self->{pbot}->{bantracker}->track_mode("$nick!$user\@$host", $mode, $target, $channel); } - if (defined $target and length $target) { - my $message_account = $self->{pbot}->{messagehistory}->get_message_account($nick, $user, $host); - $self->{pbot}->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $channel, "MODE $mode $target", $self->{pbot}->{messagehistory}->{MSG_CHAT}); + if (defined $target and length $target) { + my $message_account = $self->{pbot}->{messagehistory}->get_message_account($nick, $user, $host); + $self->{pbot}->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $channel, "MODE $mode $target", $self->{pbot}->{messagehistory}->{MSG_CHAT}); - if ($modifier eq '-') { - $self->{pbot}->{nicklist}->delete_meta($channel, $target, "+$mode_char"); - } else { - $self->{pbot}->{nicklist}->set_meta($channel, $target, $mode, 1); - } - } else { - my $modes = $self->{pbot}->{channels}->get_meta($channel, 'MODE'); - if (defined $modes) { - if ($modifier eq '+') { - $modes = '+' if not length $modes; - $modes .= $mode_char; + if ($modifier eq '-') { $self->{pbot}->{nicklist}->delete_meta($channel, $target, "+$mode_char"); } + else { $self->{pbot}->{nicklist}->set_meta($channel, $target, $mode, 1); } } else { - $modes =~ s/\Q$mode_char\E//g; - } - $self->{pbot}->{channels}->{channels}->set($channel, 'MODE', $modes, 1); - } - } - - if (defined $target && $target eq $event->{conn}->nick) { # bot targeted - if ($mode eq "+o") { - $self->{pbot}->{logger}->log("$nick opped me in $channel\n"); - my $timeout = $self->{pbot}->{registry}->get_value($channel, 'deop_timeout') // $self->{pbot}->{registry}->get_value('general', 'deop_timeout'); - $self->{pbot}->{chanops}->{is_opped}->{$channel}{timeout} = gettimeofday + $timeout; - delete $self->{pbot}->{chanops}->{op_requested}->{$channel}; - $self->{pbot}->{chanops}->perform_op_commands($channel); - } - elsif ($mode eq "-o") { - $self->{pbot}->{logger}->log("$nick removed my ops in $channel\n"); - delete $self->{pbot}->{chanops}->{is_opped}->{$channel}; - } - elsif ($mode eq "+b") { - $self->{pbot}->{logger}->log("Got banned in $channel, attempting unban."); - $event->{conn}->privmsg("chanserv", "unban $channel"); - } - } - else { # bot not targeted - if ($mode eq "+b") { - if ($nick eq "ChanServ" or $target =~ m/##fix_your_connection$/i) { - if ($self->{pbot}->{chanops}->can_gain_ops($channel)) { - if ($self->{pbot}->{chanops}->{unban_timeout}->exists($channel, $target)) { - $self->{pbot}->{chanops}->{unban_timeout}->set($channel, $target, 'timeout', gettimeofday + $self->{pbot}->{registry}->get_value('bantracker', 'chanserv_ban_timeout')); - } else { - my $data = { - reason => 'Temp ban for banned-by-ChanServ or mask is *!*@*##fix_your_connection', - owner => $self->{pbot}->{registry}->get_value('irc', 'botnick'), - timeout => gettimeofday + $self->{pbot}->{registry}->get_value('bantracker', 'chanserv_ban_timeout'), - }; - $self->{pbot}->{chanops}->{unban_timeout}->add($channel, $target, $data); + my $modes = $self->{pbot}->{channels}->get_meta($channel, 'MODE'); + if (defined $modes) { + if ($modifier eq '+') { + $modes = '+' if not length $modes; + $modes .= $mode_char; + } else { + $modes =~ s/\Q$mode_char\E//g; + } + $self->{pbot}->{channels}->{channels}->set($channel, 'MODE', $modes, 1); } - } - } elsif ($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 = { - reason => 'Temp ban for *!*@... banmask', - timeout => gettimeofday + $timeout, - owner => $self->{pbot}->{registry}->get_value('irc', 'botnick'), - }; - $self->{pbot}->{chanops}->{unban_timeout}->add($channel, $target, $data); - } - } } - } - elsif ($mode eq "+q") { - if ($nick ne $event->{conn}->nick) { # bot muted - if ($self->{pbot}->{chanops}->can_gain_ops($channel)) { - if ($self->{pbot}->{chanops}->{unmute_timeout}->exists($channel, $target)) { - $self->{pbot}->{chanops}->{unmute_timeout}->set($channel, $target, 'timeout', gettimeofday + $self->{pbot}->{registry}->get_value('bantracker', 'chanserv_ban_timeout')); - } else { - my $data = { - reason => 'Temp mute', - owner => $self->{pbot}->{registry}->get_value('irc', 'botnick'), - timeout => gettimeofday + $self->{pbot}->{registry}->get_value('bantracker', 'mute_timeout'), - }; - $self->{pbot}->{chanops}->{unmute_timeout}->add($channel, $target, $data); + + if (defined $target && $target eq $event->{conn}->nick) { # bot targeted + if ($mode eq "+o") { + $self->{pbot}->{logger}->log("$nick opped me in $channel\n"); + my $timeout = $self->{pbot}->{registry}->get_value($channel, 'deop_timeout') // $self->{pbot}->{registry}->get_value('general', 'deop_timeout'); + $self->{pbot}->{chanops}->{is_opped}->{$channel}{timeout} = gettimeofday + $timeout; + delete $self->{pbot}->{chanops}->{op_requested}->{$channel}; + $self->{pbot}->{chanops}->perform_op_commands($channel); + } elsif ($mode eq "-o") { + $self->{pbot}->{logger}->log("$nick removed my ops in $channel\n"); + delete $self->{pbot}->{chanops}->{is_opped}->{$channel}; + } elsif ($mode eq "+b") { + $self->{pbot}->{logger}->log("Got banned in $channel, attempting unban."); + $event->{conn}->privmsg("chanserv", "unban $channel"); + } + } else { # bot not targeted + if ($mode eq "+b") { + if ($nick eq "ChanServ" or $target =~ m/##fix_your_connection$/i) { + if ($self->{pbot}->{chanops}->can_gain_ops($channel)) { + if ($self->{pbot}->{chanops}->{unban_timeout}->exists($channel, $target)) { + $self->{pbot}->{chanops}->{unban_timeout}->set($channel, $target, 'timeout', gettimeofday + $self->{pbot}->{registry}->get_value('bantracker', 'chanserv_ban_timeout')); + } else { + my $data = { + reason => 'Temp ban for banned-by-ChanServ or mask is *!*@*##fix_your_connection', + owner => $self->{pbot}->{registry}->get_value('irc', 'botnick'), + timeout => gettimeofday + $self->{pbot}->{registry}->get_value('bantracker', 'chanserv_ban_timeout'), + }; + $self->{pbot}->{chanops}->{unban_timeout}->add($channel, $target, $data); + } + } + } elsif ($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 = { + reason => 'Temp ban for *!*@... banmask', + timeout => gettimeofday + $timeout, + owner => $self->{pbot}->{registry}->get_value('irc', 'botnick'), + }; + $self->{pbot}->{chanops}->{unban_timeout}->add($channel, $target, $data); + } + } + } + } elsif ($mode eq "+q") { + if ($nick ne $event->{conn}->nick) { # bot muted + if ($self->{pbot}->{chanops}->can_gain_ops($channel)) { + if ($self->{pbot}->{chanops}->{unmute_timeout}->exists($channel, $target)) { + $self->{pbot}->{chanops}->{unmute_timeout}->set($channel, $target, 'timeout', gettimeofday + $self->{pbot}->{registry}->get_value('bantracker', 'chanserv_ban_timeout')); + } else { + my $data = { + reason => 'Temp mute', + owner => $self->{pbot}->{registry}->get_value('irc', 'botnick'), + timeout => gettimeofday + $self->{pbot}->{registry}->get_value('bantracker', 'mute_timeout'), + }; + $self->{pbot}->{chanops}->{unmute_timeout}->add($channel, $target, $data); + } + } + } } - } } - } } - } - return 0; + 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); - ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); + ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); - $channel = lc $channel; + $channel = lc $channel; - my $message_account = $self->{pbot}->{messagehistory}->get_message_account($nick, $user, $host); - $self->{pbot}->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $channel, "JOIN", $self->{pbot}->{messagehistory}->{MSG_JOIN}); + my $message_account = $self->{pbot}->{messagehistory}->get_message_account($nick, $user, $host); + $self->{pbot}->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $channel, "JOIN", $self->{pbot}->{messagehistory}->{MSG_JOIN}); - $self->{pbot}->{messagehistory}->{database}->devalidate_channel($message_account, $channel); + $self->{pbot}->{messagehistory}->{database}->devalidate_channel($message_account, $channel); - my $msg = 'JOIN'; + my $msg = 'JOIN'; - if (exists $self->{pbot}->{irc_capabilities}->{'extended-join'}) { - $msg .= " $event->{event}->{args}[0] :$event->{event}->{args}[1]"; + if (exists $self->{pbot}->{irc_capabilities}->{'extended-join'}) { + $msg .= " $event->{event}->{args}[0] :$event->{event}->{args}[1]"; - $self->{pbot}->{messagehistory}->{database}->update_gecos($message_account, $event->{event}->{args}[1], scalar gettimeofday); + $self->{pbot}->{messagehistory}->{database}->update_gecos($message_account, $event->{event}->{args}[1], scalar gettimeofday); - if ($event->{event}->{args}[0] ne '*') { - $self->{pbot}->{messagehistory}->{database}->link_aliases($message_account, undef, $event->{event}->{args}[0]); - $self->{pbot}->{antiflood}->check_nickserv_accounts($nick, $event->{event}->{args}[0]); - } else { - $self->{pbot}->{messagehistory}->{database}->set_current_nickserv_account($message_account, ''); + if ($event->{event}->{args}[0] ne '*') { + $self->{pbot}->{messagehistory}->{database}->link_aliases($message_account, undef, $event->{event}->{args}[0]); + $self->{pbot}->{antiflood}->check_nickserv_accounts($nick, $event->{event}->{args}[0]); + } else { + $self->{pbot}->{messagehistory}->{database}->set_current_nickserv_account($message_account, ''); + } + + $self->{pbot}->{antiflood}->check_bans($message_account, $event->{event}->from, $channel); } - $self->{pbot}->{antiflood}->check_bans($message_account, $event->{event}->from, $channel); - } - - $self->{pbot}->{antiflood}->check_flood($channel, $nick, $user, $host, $msg, - $self->{pbot}->{registry}->get_value('antiflood', 'join_flood_threshold'), - $self->{pbot}->{registry}->get_value('antiflood', 'join_flood_time_threshold'), - $self->{pbot}->{messagehistory}->{MSG_JOIN}); - return 0; + $self->{pbot}->{antiflood}->check_flood( + $channel, $nick, $user, $host, $msg, + $self->{pbot}->{registry}->get_value('antiflood', 'join_flood_threshold'), + $self->{pbot}->{registry}->get_value('antiflood', 'join_flood_time_threshold'), + $self->{pbot}->{messagehistory}->{MSG_JOIN} + ); + return 0; } sub on_invite { - my ($self, $event_type, $event) = @_; - my ($nick, $user, $host, $target, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to, $event->{event}->{args}[0]); + my ($self, $event_type, $event) = @_; + my ($nick, $user, $host, $target, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to, $event->{event}->{args}[0]); - ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); + ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); - $channel = lc $channel; + $channel = lc $channel; - $self->{pbot}->{logger}->log("$nick!$user\@$host invited $target to $channel!\n"); + $self->{pbot}->{logger}->log("$nick!$user\@$host invited $target to $channel!\n"); - if ($target eq $self->{pbot}->{registry}->get_value('irc', 'botnick')) { - if ($self->{pbot}->{channels}->is_active($channel)) { - $self->{pbot}->{interpreter}->add_botcmd_to_command_queue($channel, "join $channel", 0); + if ($target eq $self->{pbot}->{registry}->get_value('irc', 'botnick')) { + if ($self->{pbot}->{channels}->is_active($channel)) { $self->{pbot}->{interpreter}->add_botcmd_to_command_queue($channel, "join $channel", 0); } } - } - return 0; + return 0; } 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]); - $channel = lc $channel; + 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; - ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); + ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); - $self->{pbot}->{logger}->log("$nick!$user\@$host kicked $target from $channel ($reason)\n"); + $self->{pbot}->{logger}->log("$nick!$user\@$host kicked $target from $channel ($reason)\n"); - my ($message_account) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($target); + my ($message_account) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($target); - my $hostmask; - if (defined $message_account) { - $hostmask = $self->{pbot}->{messagehistory}->{database}->find_most_recent_hostmask($message_account); + my $hostmask; + if (defined $message_account) { + $hostmask = $self->{pbot}->{messagehistory}->{database}->find_most_recent_hostmask($message_account); - my ($target_nick, $target_user, $target_host) = $hostmask =~ m/^([^!]+)!([^@]+)@(.*)/; - my $text = "KICKED by $nick!$user\@$host ($reason)"; + my ($target_nick, $target_user, $target_host) = $hostmask =~ m/^([^!]+)!([^@]+)@(.*)/; + my $text = "KICKED by $nick!$user\@$host ($reason)"; - $self->{pbot}->{messagehistory}->add_message($message_account, $hostmask, $channel, $text, $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}); - $self->{pbot}->{antiflood}->check_flood($channel, $target_nick, $target_user, $target_host, $text, - $self->{pbot}->{registry}->get_value('antiflood', 'join_flood_threshold'), - $self->{pbot}->{registry}->get_value('antiflood', 'join_flood_time_threshold'), - $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}); - } + $self->{pbot}->{messagehistory}->add_message($message_account, $hostmask, $channel, $text, $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}); + $self->{pbot}->{antiflood}->check_flood( + $channel, $target_nick, $target_user, $target_host, $text, + $self->{pbot}->{registry}->get_value('antiflood', 'join_flood_threshold'), + $self->{pbot}->{registry}->get_value('antiflood', 'join_flood_time_threshold'), + $self->{pbot}->{messagehistory}->{MSG_DEPARTURE} + ); + } - $message_account = $self->{pbot}->{messagehistory}->{database}->get_message_account_id("$nick!$user\@$host"); + $message_account = $self->{pbot}->{messagehistory}->{database}->get_message_account_id("$nick!$user\@$host"); - if (defined $message_account) { - my $text = "KICKED " . (defined $hostmask ? $hostmask : $target) . " from $channel ($reason)"; - $self->{pbot}->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $channel, $text, $self->{pbot}->{messagehistory}->{MSG_CHAT}); - } - return 0; + if (defined $message_account) { + my $text = "KICKED " . (defined $hostmask ? $hostmask : $target) . " from $channel ($reason)"; + $self->{pbot}->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $channel, $text, $self->{pbot}->{messagehistory}->{MSG_CHAT}); + } + 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; + 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; - ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); + ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); - my $text = uc $event->{event}->type; - $text .= " $args"; + my $text = uc $event->{event}->type; + $text .= " $args"; - my $message_account = $self->{pbot}->{messagehistory}->get_message_account($nick, $user, $host); + my $message_account = $self->{pbot}->{messagehistory}->get_message_account($nick, $user, $host); - if ($text =~ m/^QUIT/) { - # QUIT messages must be dispatched to each channel the user is on - my $channels = $self->{pbot}->{nicklist}->get_channels($nick); - foreach my $chan (@$channels) { - next if $chan !~ m/^#/; - $self->{pbot}->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $chan, $text, $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}); + if ($text =~ m/^QUIT/) { + + # QUIT messages must be dispatched to each channel the user is on + my $channels = $self->{pbot}->{nicklist}->get_channels($nick); + foreach my $chan (@$channels) { + next if $chan !~ m/^#/; + $self->{pbot}->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $chan, $text, $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}); + } + } else { + $self->{pbot}->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $channel, $text, $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}); } - } else { - $self->{pbot}->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $channel, $text, $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}); - } - $self->{pbot}->{antiflood}->check_flood($channel, $nick, $user, $host, $text, - $self->{pbot}->{registry}->get_value('antiflood', 'join_flood_threshold'), - $self->{pbot}->{registry}->get_value('antiflood', 'join_flood_time_threshold'), - $self->{pbot}->{messagehistory}->{MSG_DEPARTURE}); + $self->{pbot}->{antiflood}->check_flood( + $channel, $nick, $user, $host, $text, + $self->{pbot}->{registry}->get_value('antiflood', 'join_flood_threshold'), + $self->{pbot}->{registry}->get_value('antiflood', 'join_flood_time_threshold'), + $self->{pbot}->{messagehistory}->{MSG_DEPARTURE} + ); - my $u = $self->{pbot}->{users}->find_user($channel, "$nick!$user\@$host"); - if (defined $u and $u->{loggedin} and not $u->{stayloggedin}) { - $self->{pbot}->{logger}->log("Logged out $nick.\n"); - delete $u->{loggedin}; - $self->{pbot}->{users}->save; - } - return 0; + my $u = $self->{pbot}->{users}->find_user($channel, "$nick!$user\@$host"); + if (defined $u and $u->{loggedin} and not $u->{stayloggedin}) { + $self->{pbot}->{logger}->log("Logged out $nick.\n"); + delete $u->{loggedin}; + $self->{pbot}->{users}->save; + } + return 0; } sub on_map { - my ($self, $event_type, $event) = @_; + my ($self, $event_type, $event) = @_; - # remove and discard first and last elements - shift @{ $event->{event}->{args} }; - pop @{ $event->{event}->{args} }; + # remove and discard first and last elements + shift @{$event->{event}->{args}}; + pop @{$event->{event}->{args}}; - foreach my $arg (@{ $event->{event}->{args} }) { - my ($key, $value) = split /=/, $arg; - $self->{pbot}->{ircd}->{$key} = $value; - $self->{pbot}->{logger}->log(" $key\n") if not defined $value; - $self->{pbot}->{logger}->log(" $key=$value\n") if defined $value; - } + foreach my $arg (@{$event->{event}->{args}}) { + my ($key, $value) = split /=/, $arg; + $self->{pbot}->{ircd}->{$key} = $value; + $self->{pbot}->{logger}->log(" $key\n") if not defined $value; + $self->{pbot}->{logger}->log(" $key=$value\n") if defined $value; + } } sub on_cap { - my ($self, $event_type, $event) = @_; + my ($self, $event_type, $event) = @_; - if ($event->{event}->{args}->[0] eq 'ACK') { - $self->{pbot}->{logger}->log("Client capabilities granted: " . $event->{event}->{args}->[1] . "\n"); + if ($event->{event}->{args}->[0] eq 'ACK') { + $self->{pbot}->{logger}->log("Client capabilities granted: " . $event->{event}->{args}->[1] . "\n"); - my @caps = split /\s+/, $event->{event}->{args}->[1]; - foreach my $cap (@caps) { - $self->{pbot}->{irc_capabilities}->{$cap} = 1; + my @caps = split /\s+/, $event->{event}->{args}->[1]; + foreach my $cap (@caps) { $self->{pbot}->{irc_capabilities}->{$cap} = 1; } + } else { + $self->{pbot}->{logger}->log(Dumper $event->{event}); } - } else { - $self->{pbot}->{logger}->log(Dumper $event->{event}); - } - return 0; + 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); - ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); + ($nick, $user, $host) = $self->normalize_hostmask($nick, $user, $host); - $self->{pbot}->{logger}->log("[NICKCHANGE] $nick!$user\@$host changed nick to $newnick\n"); + $self->{pbot}->{logger}->log("[NICKCHANGE] $nick!$user\@$host changed nick to $newnick\n"); + + if ($newnick eq $self->{pbot}->{registry}->get_value('irc', 'botnick') and not $self->{pbot}->{joined_channels}) { + $self->{pbot}->{channels}->autojoin; + return 0; + } + + my $message_account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + $self->{pbot}->{messagehistory}->{database}->devalidate_all_channels($message_account, $self->{pbot}->{antiflood}->{NEEDS_CHECKBAN}); + my $channels = $self->{pbot}->{nicklist}->get_channels($nick); + foreach my $channel (@$channels) { + next if $channel !~ m/^#/; + $self->{pbot}->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $channel, "NICKCHANGE $newnick", $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}); + } + $self->{pbot}->{messagehistory}->{database}->update_hostmask_data("$nick!$user\@$host", {last_seen => scalar gettimeofday}); + + my $newnick_account = $self->{pbot}->{messagehistory}->{database}->get_message_account($newnick, $user, $host, $nick); + $self->{pbot}->{messagehistory}->{database}->devalidate_all_channels($newnick_account, $self->{pbot}->{antiflood}->{NEEDS_CHECKBAN}); + $self->{pbot}->{messagehistory}->{database}->update_hostmask_data("$newnick!$user\@$host", {last_seen => scalar gettimeofday}); + + $self->{pbot}->{antiflood}->check_flood( + "$nick!$user\@$host", $nick, $user, $host, "NICKCHANGE $newnick", + $self->{pbot}->{registry}->get_value('antiflood', 'nick_flood_threshold'), + $self->{pbot}->{registry}->get_value('antiflood', 'nick_flood_time_threshold'), + $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE} + ); - if ($newnick eq $self->{pbot}->{registry}->get_value('irc', 'botnick') and not $self->{pbot}->{joined_channels}) { - $self->{pbot}->{channels}->autojoin; return 0; - } - - my $message_account = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - $self->{pbot}->{messagehistory}->{database}->devalidate_all_channels($message_account, $self->{pbot}->{antiflood}->{NEEDS_CHECKBAN}); - my $channels = $self->{pbot}->{nicklist}->get_channels($nick); - foreach my $channel (@$channels) { - next if $channel !~ m/^#/; - $self->{pbot}->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $channel, "NICKCHANGE $newnick", $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}); - } - $self->{pbot}->{messagehistory}->{database}->update_hostmask_data("$nick!$user\@$host", { last_seen => scalar gettimeofday }); - - my $newnick_account = $self->{pbot}->{messagehistory}->{database}->get_message_account($newnick, $user, $host, $nick); - $self->{pbot}->{messagehistory}->{database}->devalidate_all_channels($newnick_account, $self->{pbot}->{antiflood}->{NEEDS_CHECKBAN}); - $self->{pbot}->{messagehistory}->{database}->update_hostmask_data("$newnick!$user\@$host", { last_seen => scalar gettimeofday }); - - $self->{pbot}->{antiflood}->check_flood("$nick!$user\@$host", $nick, $user, $host, "NICKCHANGE $newnick", - $self->{pbot}->{registry}->get_value('antiflood', 'nick_flood_threshold'), - $self->{pbot}->{registry}->get_value('antiflood', 'nick_flood_time_threshold'), - $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}); - - return 0; } sub on_nicknameinuse { - my ($self, $event_type, $event) = @_; - my (undef, $nick, $msg) = $event->{event}->args; - my $from = $event->{event}->from; + my ($self, $event_type, $event) = @_; + my (undef, $nick, $msg) = $event->{event}->args; + my $from = $event->{event}->from; - $self->{pbot}->{logger}->log("Received nicknameinuse for nick $nick from $from: $msg\n"); - $event->{conn}->privmsg("nickserv", "ghost $nick " . $self->{pbot}->{registry}->get_value('irc', 'identify_password')); - return 0; + $self->{pbot}->{logger}->log("Received nicknameinuse for nick $nick from $from: $msg\n"); + $event->{conn}->privmsg("nickserv", "ghost $nick " . $self->{pbot}->{registry}->get_value('irc', 'identify_password')); + return 0; } sub on_channelmodeis { - my ($self, $event_type, $event) = @_; - my (undef, $channel, $modes) = $event->{event}->args; - $self->{pbot}->{logger}->log("Channel $channel modes: $modes\n"); - $self->{pbot}->{channels}->{channels}->set($channel, 'MODE', $modes, 1); + my ($self, $event_type, $event) = @_; + my (undef, $channel, $modes) = $event->{event}->args; + $self->{pbot}->{logger}->log("Channel $channel modes: $modes\n"); + $self->{pbot}->{channels}->{channels}->set($channel, 'MODE', $modes, 1); } sub on_channelcreate { - my ($self, $event_type, $event) = @_; - my ($owner, $channel, $timestamp) = $event->{event}->args; - $self->{pbot}->{logger}->log("Channel $channel created by $owner on " . localtime ($timestamp) . "\n"); - $self->{pbot}->{channels}->{channels}->set($channel, 'CREATED_BY', $owner, 1); - $self->{pbot}->{channels}->{channels}->set($channel, 'CREATED_ON', $timestamp, 1); + my ($self, $event_type, $event) = @_; + my ($owner, $channel, $timestamp) = $event->{event}->args; + $self->{pbot}->{logger}->log("Channel $channel created by $owner on " . localtime($timestamp) . "\n"); + $self->{pbot}->{channels}->{channels}->set($channel, 'CREATED_BY', $owner, 1); + $self->{pbot}->{channels}->{channels}->set($channel, 'CREATED_ON', $timestamp, 1); } sub on_topic { - my ($self, $event_type, $event) = @_; + my ($self, $event_type, $event) = @_; - if (not length $event->{event}->{to}->[0]) { - # on join - my (undef, $channel, $topic) = $event->{event}->args; - $self->{pbot}->{logger}->log("Topic for $channel: $topic\n"); - $self->{pbot}->{channels}->{channels}->set($channel, 'TOPIC', $topic, 1); - } else { - # user changing topic - my ($nick, $user, $host) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host); - my $channel = $event->{event}->{to}->[0]; - my $topic = $event->{event}->{args}->[0]; + if (not length $event->{event}->{to}->[0]) { - $self->{pbot}->{logger}->log("$nick!$user\@$host changed topic for $channel to: $topic\n"); - $self->{pbot}->{channels}->{channels}->set($channel, 'TOPIC', $topic, 1); - $self->{pbot}->{channels}->{channels}->set($channel, 'TOPIC_SET_BY', "$nick!$user\@$host", 1); - $self->{pbot}->{channels}->{channels}->set($channel, 'TOPIC_SET_ON', gettimeofday); - } + # on join + my (undef, $channel, $topic) = $event->{event}->args; + $self->{pbot}->{logger}->log("Topic for $channel: $topic\n"); + $self->{pbot}->{channels}->{channels}->set($channel, 'TOPIC', $topic, 1); + } else { + + # user changing topic + my ($nick, $user, $host) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host); + my $channel = $event->{event}->{to}->[0]; + my $topic = $event->{event}->{args}->[0]; + + $self->{pbot}->{logger}->log("$nick!$user\@$host changed topic for $channel to: $topic\n"); + $self->{pbot}->{channels}->{channels}->set($channel, 'TOPIC', $topic, 1); + $self->{pbot}->{channels}->{channels}->set($channel, 'TOPIC_SET_BY', "$nick!$user\@$host", 1); + $self->{pbot}->{channels}->{channels}->set($channel, 'TOPIC_SET_ON', gettimeofday); + } } sub on_topicinfo { - my ($self, $event_type, $event) = @_; - my (undef, $channel, $by, $timestamp) = $event->{event}->args; - $self->{pbot}->{logger}->log("Topic for $channel set by $by on " . localtime ($timestamp) . "\n"); - $self->{pbot}->{channels}->{channels}->set($channel, 'TOPIC_SET_BY', $by, 1); - $self->{pbot}->{channels}->{channels}->set($channel, 'TOPIC_SET_ON', $timestamp, 1); + my ($self, $event_type, $event) = @_; + my (undef, $channel, $by, $timestamp) = $event->{event}->args; + $self->{pbot}->{logger}->log("Topic for $channel set by $by on " . localtime($timestamp) . "\n"); + $self->{pbot}->{channels}->{channels}->set($channel, 'TOPIC_SET_BY', $by, 1); + $self->{pbot}->{channels}->{channels}->set($channel, 'TOPIC_SET_ON', $timestamp, 1); } sub normalize_hostmask { - my ($self, $nick, $user, $host) = @_; + my ($self, $nick, $user, $host) = @_; - if ($host =~ m{^(gateway|nat)/(.*)/x-[^/]+$}) { - $host = "$1/$2/x-$user"; - } + if ($host =~ m{^(gateway|nat)/(.*)/x-[^/]+$}) { $host = "$1/$2/x-$user"; } - $host =~ s{/session$}{/x-$user}; + $host =~ s{/session$}{/x-$user}; - return ($nick, $user, $host); + return ($nick, $user, $host); } my %who_queue; @@ -596,120 +590,120 @@ my $last_who_id; my $who_pending = 0; sub on_whoreply { - my ($self, $event_type, $event) = @_; + my ($self, $event_type, $event) = @_; - my ($ignored, $id, $user, $host, $server, $nick, $usermodes, $gecos) = @{$event->{event}->{args}}; - ($nick, $user, $host) = $self->{pbot}->{irchandlers}->normalize_hostmask($nick, $user, $host); - my $hostmask = "$nick!$user\@$host"; - my $channel; + my ($ignored, $id, $user, $host, $server, $nick, $usermodes, $gecos) = @{$event->{event}->{args}}; + ($nick, $user, $host) = $self->{pbot}->{irchandlers}->normalize_hostmask($nick, $user, $host); + my $hostmask = "$nick!$user\@$host"; + my $channel; - if ($id =~ m/^#/) { - $id = lc $id; - foreach my $x (keys %who_cache) { - if ($who_cache{$x} eq $id) { - $id = $x; - last; - } + if ($id =~ m/^#/) { + $id = lc $id; + foreach my $x (keys %who_cache) { + if ($who_cache{$x} eq $id) { + $id = $x; + last; + } + } } - } - $last_who_id = $id; - $channel = $who_cache{$id}; - delete $who_queue{$id}; + $last_who_id = $id; + $channel = $who_cache{$id}; + delete $who_queue{$id}; - return 0 if not defined $channel; + return 0 if not defined $channel; - $self->{pbot}->{logger}->log("WHO id: $id [$channel], hostmask: $hostmask, $usermodes, $server, $gecos.\n"); + $self->{pbot}->{logger}->log("WHO id: $id [$channel], hostmask: $hostmask, $usermodes, $server, $gecos.\n"); - $self->{pbot}->{nicklist}->add_nick($channel, $nick); - $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'hostmask', $hostmask); - $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'user', $user); - $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'host', $host); - $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'server', $server); - $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'gecos', $gecos); + $self->{pbot}->{nicklist}->add_nick($channel, $nick); + $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'hostmask', $hostmask); + $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'user', $user); + $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'host', $host); + $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'server', $server); + $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'gecos', $gecos); - my $account_id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - $self->{pbot}->{messagehistory}->{database}->update_hostmask_data($hostmask, { last_seen => scalar gettimeofday }); + my $account_id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + $self->{pbot}->{messagehistory}->{database}->update_hostmask_data($hostmask, {last_seen => scalar gettimeofday}); - $self->{pbot}->{messagehistory}->{database}->link_aliases($account_id, $hostmask, undef); + $self->{pbot}->{messagehistory}->{database}->link_aliases($account_id, $hostmask, undef); - $self->{pbot}->{messagehistory}->{database}->devalidate_channel($account_id, $channel); - $self->{pbot}->{antiflood}->check_bans($account_id, $hostmask, $channel); + $self->{pbot}->{messagehistory}->{database}->devalidate_channel($account_id, $channel); + $self->{pbot}->{antiflood}->check_bans($account_id, $hostmask, $channel); - return 0; + return 0; } sub on_whospcrpl { - my ($self, $event_type, $event) = @_; + my ($self, $event_type, $event) = @_; - my ($ignored, $id, $user, $host, $nick, $nickserv, $gecos) = @{$event->{event}->{args}}; - ($nick, $user, $host) = $self->{pbot}->{irchandlers}->normalize_hostmask($nick, $user, $host); - $last_who_id = $id; - my $hostmask = "$nick!$user\@$host"; - my $channel = $who_cache{$id}; - delete $who_queue{$id}; + my ($ignored, $id, $user, $host, $nick, $nickserv, $gecos) = @{$event->{event}->{args}}; + ($nick, $user, $host) = $self->{pbot}->{irchandlers}->normalize_hostmask($nick, $user, $host); + $last_who_id = $id; + my $hostmask = "$nick!$user\@$host"; + my $channel = $who_cache{$id}; + delete $who_queue{$id}; - return 0 if not defined $channel; + return 0 if not defined $channel; - $self->{pbot}->{logger}->log("WHO id: $id [$channel], hostmask: $hostmask, $nickserv, $gecos.\n"); + $self->{pbot}->{logger}->log("WHO id: $id [$channel], hostmask: $hostmask, $nickserv, $gecos.\n"); - $self->{pbot}->{nicklist}->add_nick($channel, $nick); - $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'hostmask', $hostmask); - $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'user', $user); - $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'host', $host); - $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'nickserv', $nickserv) if $nickserv ne '0'; - $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'gecos', $gecos); + $self->{pbot}->{nicklist}->add_nick($channel, $nick); + $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'hostmask', $hostmask); + $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'user', $user); + $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'host', $host); + $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'nickserv', $nickserv) if $nickserv ne '0'; + $self->{pbot}->{nicklist}->set_meta($channel, $nick, 'gecos', $gecos); - my $account_id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - $self->{pbot}->{messagehistory}->{database}->update_hostmask_data($hostmask, { last_seen => scalar gettimeofday }); + my $account_id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + $self->{pbot}->{messagehistory}->{database}->update_hostmask_data($hostmask, {last_seen => scalar gettimeofday}); - if ($nickserv ne '0') { - $self->{pbot}->{messagehistory}->{database}->link_aliases($account_id, undef, $nickserv); - $self->{pbot}->{antiflood}->check_nickserv_accounts($nick, $nickserv); - } + if ($nickserv ne '0') { + $self->{pbot}->{messagehistory}->{database}->link_aliases($account_id, undef, $nickserv); + $self->{pbot}->{antiflood}->check_nickserv_accounts($nick, $nickserv); + } - $self->{pbot}->{messagehistory}->{database}->link_aliases($account_id, $hostmask, undef); + $self->{pbot}->{messagehistory}->{database}->link_aliases($account_id, $hostmask, undef); - $self->{pbot}->{messagehistory}->{database}->devalidate_channel($account_id, $channel); - $self->{pbot}->{antiflood}->check_bans($account_id, $hostmask, $channel); + $self->{pbot}->{messagehistory}->{database}->devalidate_channel($account_id, $channel); + $self->{pbot}->{antiflood}->check_bans($account_id, $hostmask, $channel); - return 0; + return 0; } sub on_endofwho { - my ($self, $event_type, $event) = @_; - $self->{pbot}->{logger}->log("WHO session $last_who_id ($who_cache{$last_who_id}) completed.\n"); - delete $who_cache{$last_who_id}; - delete $who_queue{$last_who_id}; - $who_pending = 0; - return 0; + my ($self, $event_type, $event) = @_; + $self->{pbot}->{logger}->log("WHO session $last_who_id ($who_cache{$last_who_id}) completed.\n"); + delete $who_cache{$last_who_id}; + delete $who_queue{$last_who_id}; + $who_pending = 0; + return 0; } sub send_who { - my ($self, $channel) = @_; - $channel = lc $channel; - $self->{pbot}->{logger}->log("pending WHO to $channel\n"); + my ($self, $channel) = @_; + $channel = lc $channel; + $self->{pbot}->{logger}->log("pending WHO to $channel\n"); - for (my $id = 1; $id < 99; $id++) { - if (not exists $who_cache{$id}) { - $who_cache{$id} = $channel; - $who_queue{$id} = $channel; - $last_who_id = $id; - last; + for (my $id = 1; $id < 99; $id++) { + if (not exists $who_cache{$id}) { + $who_cache{$id} = $channel; + $who_queue{$id} = $channel; + $last_who_id = $id; + last; + } } - } } sub check_pending_whos { - my $self = shift; - return if $who_pending; - foreach my $id (keys %who_queue) { - $self->{pbot}->{logger}->log("sending WHO to $who_queue{$id} [$id]\n"); - $self->{pbot}->{conn}->sl("WHO $who_queue{$id} %tuhnar,$id"); - $who_pending = 1; - $last_who_id = $id; - last; - } + my $self = shift; + return if $who_pending; + foreach my $id (keys %who_queue) { + $self->{pbot}->{logger}->log("sending WHO to $who_queue{$id} [$id]\n"); + $self->{pbot}->{conn}->sl("WHO $who_queue{$id} %tuhnar,$id"); + $who_pending = 1; + $last_who_id = $id; + last; + } } 1; diff --git a/PBot/IgnoreList.pm b/PBot/IgnoreList.pm index ef5aaa28..2979c842 100644 --- a/PBot/IgnoreList.pm +++ b/PBot/IgnoreList.pm @@ -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 = ; - 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 = ; + 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; diff --git a/PBot/IgnoreListCommands.pm b/PBot/IgnoreListCommands.pm index 59697e2c..5f800540 100644 --- a/PBot/IgnoreListCommands.pm +++ b/PBot/IgnoreListCommands.pm @@ -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 [channel [timeout]]" if not defined $arguments; + return "Usage: ignore [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 [channel [timeout]]"; - } + if (not defined $target) { return "Usage: ignore [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 [channel]"; - } + if (not defined $target) { return "Usage: unignore [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; diff --git a/PBot/Interpreter.pm b/PBot/Interpreter.pm index 0033fad6..9c350ebc 100644 --- a/PBot/Interpreter.pm +++ b/PBot/Interpreter.pm @@ -8,6 +8,7 @@ # file, You can obtain one at http://mozilla.org/MPL/2.0/. package PBot::Interpreter; + use parent 'PBot::Class', 'PBot::Registerable'; use warnings; use strict; @@ -19,489 +20,480 @@ use Time::Duration; use PBot::Utils::ValidateString; sub initialize { - my ($self, %conf) = @_; - $self->PBot::Registerable::initialize(%conf); + my ($self, %conf) = @_; + $self->PBot::Registerable::initialize(%conf); - $self->{pbot}->{registry}->add_default('text', 'general', 'compile_blocks', $conf{compile_blocks} // 1); - $self->{pbot}->{registry}->add_default('array', 'general', 'compile_blocks_channels', $conf{compile_blocks_channels} // '.*'); - $self->{pbot}->{registry}->add_default('array', 'general', 'compile_blocks_ignore_channels', $conf{compile_blocks_ignore_channels} // 'none'); - $self->{pbot}->{registry}->add_default('text', 'interpreter', 'max_recursion', 10); + $self->{pbot}->{registry}->add_default('text', 'general', 'compile_blocks', $conf{compile_blocks} // 1); + $self->{pbot}->{registry}->add_default('array', 'general', 'compile_blocks_channels', $conf{compile_blocks_channels} // '.*'); + $self->{pbot}->{registry}->add_default('array', 'general', 'compile_blocks_ignore_channels', $conf{compile_blocks_ignore_channels} // 'none'); + $self->{pbot}->{registry}->add_default('text', 'interpreter', 'max_recursion', 10); - $self->{output_queue} = {}; - $self->{command_queue} = {}; + $self->{output_queue} = {}; + $self->{command_queue} = {}; - $self->{pbot}->{timer}->register(sub { $self->process_output_queue }, 1); - $self->{pbot}->{timer}->register(sub { $self->process_command_queue }, 1); + $self->{pbot}->{timer}->register(sub { $self->process_output_queue }, 1); + $self->{pbot}->{timer}->register(sub { $self->process_command_queue }, 1); } sub process_line { - my $self = shift; - my ($from, $nick, $user, $host, $text) = @_; - $from = lc $from if defined $from; + my $self = shift; + my ($from, $nick, $user, $host, $text) = @_; + $from = lc $from if defined $from; - my $stuff = { from => $from, nick => $nick, user => $user, host => $host, text => $text }; - my $pbot = $self->{pbot}; + my $stuff = {from => $from, nick => $nick, user => $user, host => $host, text => $text}; + my $pbot = $self->{pbot}; - my $message_account = $pbot->{messagehistory}->get_message_account($nick, $user, $host); - $pbot->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $from, $text, $pbot->{messagehistory}->{MSG_CHAT}); - $stuff->{message_account} = $message_account; + my $message_account = $pbot->{messagehistory}->get_message_account($nick, $user, $host); + $pbot->{messagehistory}->add_message($message_account, "$nick!$user\@$host", $from, $text, $pbot->{messagehistory}->{MSG_CHAT}); + $stuff->{message_account} = $message_account; - my $flood_threshold = $pbot->{registry}->get_value($from, 'chat_flood_threshold'); - my $flood_time_threshold = $pbot->{registry}->get_value($from, 'chat_flood_time_threshold'); + my $flood_threshold = $pbot->{registry}->get_value($from, 'chat_flood_threshold'); + my $flood_time_threshold = $pbot->{registry}->get_value($from, 'chat_flood_time_threshold'); - $flood_threshold = $pbot->{registry}->get_value('antiflood', 'chat_flood_threshold') if not defined $flood_threshold; - $flood_time_threshold = $pbot->{registry}->get_value('antiflood', 'chat_flood_time_threshold') if not defined $flood_time_threshold; + $flood_threshold = $pbot->{registry}->get_value('antiflood', 'chat_flood_threshold') if not defined $flood_threshold; + $flood_time_threshold = $pbot->{registry}->get_value('antiflood', 'chat_flood_time_threshold') if not defined $flood_time_threshold; - if (defined $from and $from =~ m/^#/) { - my $chanmodes = $self->{pbot}->{channels}->get_meta($from, 'MODE'); - if (defined $chanmodes and $chanmodes =~ m/z/) { - $stuff->{'chan-z'} = 1; - if (exists $self->{pbot}->{bantracker}->{banlist}->{$from}->{'+q'}->{'$~a'}) { - my $nickserv = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($message_account); - if (not defined $nickserv or not length $nickserv) { - $stuff->{unidentified} = 1; + if (defined $from and $from =~ m/^#/) { + my $chanmodes = $self->{pbot}->{channels}->get_meta($from, 'MODE'); + if (defined $chanmodes and $chanmodes =~ m/z/) { + $stuff->{'chan-z'} = 1; + if (exists $self->{pbot}->{bantracker}->{banlist}->{$from}->{'+q'}->{'$~a'}) { + my $nickserv = $self->{pbot}->{messagehistory}->{database}->get_current_nickserv_account($message_account); + if (not defined $nickserv or not length $nickserv) { $stuff->{unidentified} = 1; } + } + + if ($self->{pbot}->{bantracker}->is_banned($nick, $user, $host, $from)) { $stuff->{banned} = 1; } } - } - - if ($self->{pbot}->{bantracker}->is_banned($nick, $user, $host, $from)) { - $stuff->{banned} = 1; - } } - } - $pbot->{antiflood}->check_flood($from, $nick, $user, $host, $text, - $flood_threshold, $flood_time_threshold, - $pbot->{messagehistory}->{MSG_CHAT}, $stuff) if defined $from; + $pbot->{antiflood}->check_flood( + $from, $nick, $user, $host, $text, + $flood_threshold, $flood_time_threshold, + $pbot->{messagehistory}->{MSG_CHAT}, $stuff + ) if defined $from; - if ($stuff->{banned} or $stuff->{unidentified}) { - $self->{pbot}->{logger}->log("Disregarding banned/unidentified user message (channel $from is +z).\n"); - return 1; - } - - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - - # get channel-specific trigger if available - my $bot_trigger = $pbot->{registry}->get_value($from, 'trigger'); - - # otherwise get general trigger - if (not defined $bot_trigger) { - $bot_trigger = $pbot->{registry}->get_value('general', 'trigger'); - } - - my $nick_regex = qr/[^%!,:\(\)\+\*\/ ]+/; - - my $nick_override; - my $processed = 0; - my $preserve_whitespace = 0; - - $text =~ s/^\s+//; - $text =~ s/\s+$//; - $text = validate_string($text, 0); - - my $cmd_text = $text; - $cmd_text =~ s/^\/me\s+//; - - # check for bot command invocation - my @commands; - my $command; - my $embedded = 0; - - if ($cmd_text =~ m/^\s*($nick_regex)[,:]?\s+$bot_trigger\{\s*(.+?)\s*\}\s*$/) { - goto CHECK_EMBEDDED_CMD; - } elsif ($cmd_text =~ m/^\s*$bot_trigger\{\s*(.+?)\s*\}\s*$/) { - goto CHECK_EMBEDDED_CMD; - } elsif ($cmd_text =~ m/^\s*($nick_regex)[,:]\s+$bot_trigger\s*(.+)$/) { - my $possible_nick_override = $1; - $command = $2; - - my $similar = $self->{pbot}->{nicklist}->is_present_similar($from, $possible_nick_override); - if ($similar) { - $nick_override = $similar; - } else { - $self->{pbot}->{logger}->log("No similar nick for $possible_nick_override\n"); - return 0; + if ($stuff->{banned} or $stuff->{unidentified}) { + $self->{pbot}->{logger}->log("Disregarding banned/unidentified user message (channel $from is +z).\n"); + return 1; } - } elsif ($cmd_text =~ m/^$bot_trigger\s*(.+)$/) { - $command = $1; - } elsif ($cmd_text =~ m/^.?$botnick.?\s*(.+)$/i) { - $command = $1; - } elsif ($cmd_text =~ m/^(.+?),?\s*$botnick[?!.]*$/i) { - $command = $1; - } - # check for embedded commands + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + + # get channel-specific trigger if available + my $bot_trigger = $pbot->{registry}->get_value($from, 'trigger'); + + # otherwise get general trigger + if (not defined $bot_trigger) { $bot_trigger = $pbot->{registry}->get_value('general', 'trigger'); } + + my $nick_regex = qr/[^%!,:\(\)\+\*\/ ]+/; + + my $nick_override; + my $processed = 0; + my $preserve_whitespace = 0; + + $text =~ s/^\s+//; + $text =~ s/\s+$//; + $text = validate_string($text, 0); + + my $cmd_text = $text; + $cmd_text =~ s/^\/me\s+//; + + # check for bot command invocation + my @commands; + my $command; + my $embedded = 0; + + if ($cmd_text =~ m/^\s*($nick_regex)[,:]?\s+$bot_trigger\{\s*(.+?)\s*\}\s*$/) { goto CHECK_EMBEDDED_CMD; } + elsif ($cmd_text =~ m/^\s*$bot_trigger\{\s*(.+?)\s*\}\s*$/) { goto CHECK_EMBEDDED_CMD; } + elsif ($cmd_text =~ m/^\s*($nick_regex)[,:]\s+$bot_trigger\s*(.+)$/) { + my $possible_nick_override = $1; + $command = $2; + + my $similar = $self->{pbot}->{nicklist}->is_present_similar($from, $possible_nick_override); + if ($similar) { $nick_override = $similar; } + else { + $self->{pbot}->{logger}->log("No similar nick for $possible_nick_override\n"); + return 0; + } + } elsif ($cmd_text =~ m/^$bot_trigger\s*(.+)$/) { + $command = $1; + } elsif ($cmd_text =~ m/^.?$botnick.?\s*(.+)$/i) { + $command = $1; + } elsif ($cmd_text =~ m/^(.+?),?\s*$botnick[?!.]*$/i) { + $command = $1; + } + + # check for embedded commands CHECK_EMBEDDED_CMD: - if (not defined $command or $command =~ m/^\{.*\}/) { - if ($cmd_text =~ s/^\s*($nick_regex)[,:]\s+//) { - my $possible_nick_override = $1; - my $similar = $self->{pbot}->{nicklist}->is_present_similar($from, $possible_nick_override); - if ($similar) { - $nick_override = $similar; - } + if (not defined $command or $command =~ m/^\{.*\}/) { + if ($cmd_text =~ s/^\s*($nick_regex)[,:]\s+//) { + my $possible_nick_override = $1; + my $similar = $self->{pbot}->{nicklist}->is_present_similar($from, $possible_nick_override); + if ($similar) { $nick_override = $similar; } + } + + for (my $count = 0; $count < 3; $count++) { + my ($extracted, $rest) = $self->extract_bracketed($cmd_text, '{', '}', $bot_trigger); + last if not length $extracted; + $cmd_text = $rest; + $extracted =~ s/^\s+|\s+$//g; + push @commands, $extracted; + $embedded = 1; + } + } else { + push @commands, $command; } - for (my $count = 0; $count < 3; $count++) { - my ($extracted, $rest) = $self->extract_bracketed($cmd_text, '{', '}', $bot_trigger); - last if not length $extracted; - $cmd_text = $rest; - $extracted =~ s/^\s+|\s+$//g; - push @commands, $extracted; - $embedded = 1; + foreach $command (@commands) { + + # check if user is ignored (and command isn't `login`) + if ($command !~ /^login / && defined $from && $pbot->{ignorelist}->check_ignore($nick, $user, $host, $from)) { + if (not $pbot->{users}->loggedin_admin($from, "$nick!$user\@$host")) { + return 1; # user is ignored + } + } + + $stuff->{text} = $text; + $stuff->{command} = $command; + + if ($nick_override) { + $stuff->{nickoverride} = $nick_override; + $stuff->{force_nickoverride} = 1; + } + + $stuff->{referenced} = $embedded; + $stuff->{interpret_depth} = 1; + $stuff->{preserve_whitespace} = $preserve_whitespace; + + $stuff->{result} = $self->interpret($stuff); + $self->handle_result($stuff); + $processed++; } - } else { - push @commands, $command; - } - - foreach $command (@commands) { - # check if user is ignored (and command isn't `login`) - if ($command !~ /^login / && defined $from && $pbot->{ignorelist}->check_ignore($nick, $user, $host, $from)) { - if (not $pbot->{users}->loggedin_admin($from, "$nick!$user\@$host")) { - return 1; # user is ignored - } - } - - $stuff->{text} = $text; - $stuff->{command} = $command; - - if ($nick_override) { - $stuff->{nickoverride} = $nick_override; - $stuff->{force_nickoverride} = 1; - } - - $stuff->{referenced} = $embedded; - $stuff->{interpret_depth} = 1; - $stuff->{preserve_whitespace} = $preserve_whitespace; - - $stuff->{result} = $self->interpret($stuff); - $self->handle_result($stuff); - $processed++; - } - return $processed; + return $processed; } sub interpret { - my ($self, $stuff) = @_; - my ($keyword, $arguments) = ("", ""); - my $text; - my $pbot = $self->{pbot}; + my ($self, $stuff) = @_; + my ($keyword, $arguments) = ("", ""); + my $text; + my $pbot = $self->{pbot}; - $pbot->{logger}->log("=== [$stuff->{interpret_depth}] Got command: (" . (defined $stuff->{from} ? $stuff->{from} : "undef") . ") $stuff->{nick}!$stuff->{user}\@$stuff->{host}: $stuff->{command}\n"); + $pbot->{logger}->log("=== [$stuff->{interpret_depth}] Got command: (" + . (defined $stuff->{from} ? $stuff->{from} : "undef") + . ") $stuff->{nick}!$stuff->{user}\@$stuff->{host}: $stuff->{command}\n"); - $stuff->{special} = "" unless exists $self->{special}; + $stuff->{special} = "" unless exists $self->{special}; - if ($self->{pbot}->{registry}->get_value('general', 'debugcontext')) { - use Data::Dumper; - $Data::Dumper::Sortkeys = 1; - $self->{pbot}->{logger}->log("Interpreter::interpret\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("Interpreter::interpret\n"); + $self->{pbot}->{logger}->log(Dumper $stuff); + } - return "Too many levels of recursion, aborted." if (++$stuff->{interpret_depth} > $self->{pbot}->{registry}->get_value('interpreter', 'max_recursion')); + return "Too many levels of recursion, aborted." if (++$stuff->{interpret_depth} > $self->{pbot}->{registry}->get_value('interpreter', 'max_recursion')); - if (not defined $stuff->{nick} || not defined $stuff->{user} || not defined $stuff->{host} || not defined $stuff->{command}) { - $pbot->{logger}->log("Error 1, bad parameters to interpret_command\n"); - return undef; - } + if (not defined $stuff->{nick} || not defined $stuff->{user} || not defined $stuff->{host} || not defined $stuff->{command}) { + $pbot->{logger}->log("Error 1, bad parameters to interpret_command\n"); + return undef; + } - # check for splitted commands - if ($stuff->{command} =~ m/^(.*?)\s*(?{command} = $1; - $stuff->{command_split} = $2; - } + # check for splitted commands + if ($stuff->{command} =~ m/^(.*?)\s*(?{command} = $1; + $stuff->{command_split} = $2; + } - my $cmdlist = $self->make_args($stuff->{command}); - $stuff->{commands} = [] unless exists $stuff->{commands}; - push @{$stuff->{commands}}, $stuff->{command}; + my $cmdlist = $self->make_args($stuff->{command}); + $stuff->{commands} = [] unless exists $stuff->{commands}; + push @{$stuff->{commands}}, $stuff->{command}; - if ($self->arglist_size($cmdlist) >= 4 and lc $cmdlist->[0] eq 'tell' and (lc $cmdlist->[2] eq 'about' or lc $cmdlist->[2] eq 'the')) { - # tell nick about/the cmd [args] - $stuff->{nickoverride} = $cmdlist->[1]; - ($keyword, $arguments) = $self->split_args($cmdlist, 2, 3, 1); - $arguments = '' if not defined $arguments; - my $similar = $self->{pbot}->{nicklist}->is_present_similar($stuff->{from}, $stuff->{nickoverride}); - if ($similar) { - $stuff->{nickoverride} = $similar; - $stuff->{force_nickoverride} = 1; + if ($self->arglist_size($cmdlist) >= 4 and lc $cmdlist->[0] eq 'tell' and (lc $cmdlist->[2] eq 'about' or lc $cmdlist->[2] eq 'the')) { + + # tell nick about/the cmd [args] + $stuff->{nickoverride} = $cmdlist->[1]; + ($keyword, $arguments) = $self->split_args($cmdlist, 2, 3, 1); + $arguments = '' if not defined $arguments; + my $similar = $self->{pbot}->{nicklist}->is_present_similar($stuff->{from}, $stuff->{nickoverride}); + if ($similar) { + $stuff->{nickoverride} = $similar; + $stuff->{force_nickoverride} = 1; + } else { + delete $stuff->{nickoverride}; + delete $stuff->{force_nickoverride}; + } } else { - delete $stuff->{nickoverride}; - delete $stuff->{force_nickoverride}; + + # normal command + ($keyword, $arguments) = $self->split_args($cmdlist, 2, 0, 1); + $arguments = "" if not defined $arguments; } - } else { - # normal command - ($keyword, $arguments) = $self->split_args($cmdlist, 2, 0, 1); - $arguments = "" if not defined $arguments; - } - # FIXME: make this a registry item - if (length $keyword > 128) { - $keyword = substr($keyword, 0, 128); - $self->{pbot}->{logger}->log("Truncating keyword to 128 chars: $keyword\n"); - } - - # parse out a substituted command - if (defined $arguments && $arguments =~ m/(?extract_bracketed($arguments, '{', '}', '&', 1); - - if (length $command) { - $arguments =~ s/&\s*\{\Q$command\E\}/&{subcmd}/; - push @{$stuff->{subcmd}}, "$keyword $arguments"; - $command =~ s/^\s+|\s+$//g; - $stuff->{command} = $command; - $stuff->{commands} = []; - push @{$stuff->{commands}}, $command; - $stuff->{result} = $self->interpret($stuff); - return $stuff->{result}; + # FIXME: make this a registry item + if (length $keyword > 128) { + $keyword = substr($keyword, 0, 128); + $self->{pbot}->{logger}->log("Truncating keyword to 128 chars: $keyword\n"); } - } - # parse out a pipe - if (defined $arguments && $arguments =~ m/(?extract_bracketed($arguments, '{', '}', '|', 1); + # parse out a substituted command + if (defined $arguments && $arguments =~ m/(?extract_bracketed($arguments, '{', '}', '&', 1); - $arguments =~ s/\s*(?{pipe}) { - $stuff->{pipe_rest} = "$rest | { $stuff->{pipe} }$stuff->{pipe_rest}"; - } else { - $stuff->{pipe_rest} = $rest; + if (length $command) { + $arguments =~ s/&\s*\{\Q$command\E\}/&{subcmd}/; + push @{$stuff->{subcmd}}, "$keyword $arguments"; + $command =~ s/^\s+|\s+$//g; + $stuff->{command} = $command; + $stuff->{commands} = []; + push @{$stuff->{commands}}, $command; + $stuff->{result} = $self->interpret($stuff); + return $stuff->{result}; + } } - $stuff->{pipe} = $pipe; - } - if (not $self->{pbot}->{commands}->get_meta($keyword, 'dont-replace-pronouns') and not $self->{pbot}->{factoids}->get_meta($stuff->{from}, $keyword, 'dont-replace-pronouns')) { - $stuff->{nickoverride} = $stuff->{nick} if defined $stuff->{nickoverride} and lc $stuff->{nickoverride} eq 'me'; - $keyword =~ s/(\w+)([?!.]+)$/$1/; - $arguments =~ s/(?{nick} is/gi if defined $arguments && $stuff->{interpret_depth} <= 2; - $arguments =~ s/(?{nick}/gi if defined $arguments && $stuff->{interpret_depth} <= 2; - $arguments =~ s/(?{nick}'s/gi if defined $arguments && $stuff->{interpret_depth} <= 2; - $arguments =~ s/\\my\b/my/gi if defined $arguments && $stuff->{interpret_depth} <= 2; - $arguments =~ s/\\me\b/me/gi if defined $arguments && $stuff->{interpret_depth} <= 2; - $arguments =~ s/\\i am\b/i am/gi if defined $arguments && $stuff->{interpret_depth} <= 2; - } + # parse out a pipe + if (defined $arguments && $arguments =~ m/(?extract_bracketed($arguments, '{', '}', '|', 1); - if (not $self->{pbot}->{commands}->get_meta($keyword, 'dont-protect-self') and not $self->{pbot}->{factoids}->get_meta($stuff->{from}, $keyword, 'dont-protect-self')) { - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - if (defined $arguments && ($arguments =~ m/^(your|him|her|its|it|them|their)(self|selves)$/i || $arguments =~ m/^$botnick$/i)) { - my $delay = rand (10) + 5; - my $message = { - nick => $stuff->{nick}, user => $stuff->{user}, host => $stuff->{host}, command => $stuff->{command}, checkflood => 1, - message => "$stuff->{nick}: Why would I want to do that to myself?" - }; - $self->add_message_to_output_queue($stuff->{from}, $message, $delay); - $delay = duration($delay); - $self->{pbot}->{logger}->log("($delay delay) $message->{message}\n"); - return undef; + $arguments =~ s/\s*(?{pipe}) { $stuff->{pipe_rest} = "$rest | { $stuff->{pipe} }$stuff->{pipe_rest}"; } + else { $stuff->{pipe_rest} = $rest; } + $stuff->{pipe} = $pipe; } - } - if (not defined $keyword) { - $pbot->{logger}->log("Error 2, no keyword\n"); - return undef; - } + if ( not $self->{pbot}->{commands}->get_meta($keyword, 'dont-replace-pronouns') + and not $self->{pbot}->{factoids}->get_meta($stuff->{from}, $keyword, 'dont-replace-pronouns')) + { + $stuff->{nickoverride} = $stuff->{nick} if defined $stuff->{nickoverride} and lc $stuff->{nickoverride} eq 'me'; + $keyword =~ s/(\w+)([?!.]+)$/$1/; + $arguments =~ s/(?{nick} is/gi if defined $arguments && $stuff->{interpret_depth} <= 2; + $arguments =~ s/(?{nick}/gi if defined $arguments && $stuff->{interpret_depth} <= 2; + $arguments =~ s/(?{nick}'s/gi if defined $arguments && $stuff->{interpret_depth} <= 2; + $arguments =~ s/\\my\b/my/gi if defined $arguments && $stuff->{interpret_depth} <= 2; + $arguments =~ s/\\me\b/me/gi if defined $arguments && $stuff->{interpret_depth} <= 2; + $arguments =~ s/\\i am\b/i am/gi if defined $arguments && $stuff->{interpret_depth} <= 2; + } - if (not exists $stuff->{root_keyword}) { - $stuff->{root_keyword} = $keyword; - } + if (not $self->{pbot}->{commands}->get_meta($keyword, 'dont-protect-self') and not $self->{pbot}->{factoids}->get_meta($stuff->{from}, $keyword, 'dont-protect-self')) { + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + if (defined $arguments && ($arguments =~ m/^(your|him|her|its|it|them|their)(self|selves)$/i || $arguments =~ m/^$botnick$/i)) { + my $delay = rand(10) + 5; + my $message = { + nick => $stuff->{nick}, user => $stuff->{user}, host => $stuff->{host}, command => $stuff->{command}, checkflood => 1, + message => "$stuff->{nick}: Why would I want to do that to myself?" + }; + $self->add_message_to_output_queue($stuff->{from}, $message, $delay); + $delay = duration($delay); + $self->{pbot}->{logger}->log("($delay delay) $message->{message}\n"); + return undef; + } + } - $stuff->{keyword} = $keyword; - $stuff->{original_arguments} = $arguments; + if (not defined $keyword) { + $pbot->{logger}->log("Error 2, no keyword\n"); + return undef; + } - # unescape any escaped command splits - $arguments =~ s/\\;;;/;;;/g if defined $arguments; + if (not exists $stuff->{root_keyword}) { $stuff->{root_keyword} = $keyword; } - # unescape any escaped substituted commands - $arguments =~ s/\\&\s*\{/&{/g if defined $arguments; + $stuff->{keyword} = $keyword; + $stuff->{original_arguments} = $arguments; - # unescape any escaped pipes - $arguments =~ s/\\\|\s*\{/| {/g if defined $arguments; + # unescape any escaped command splits + $arguments =~ s/\\;;;/;;;/g if defined $arguments; - $arguments = validate_string($arguments); + # unescape any escaped substituted commands + $arguments =~ s/\\&\s*\{/&{/g if defined $arguments; - # set arguments as a plain string - $stuff->{arguments} = $arguments; - delete $stuff->{args_utf8}; + # unescape any escaped pipes + $arguments =~ s/\\\|\s*\{/| {/g if defined $arguments; - # set arguments as an array - $stuff->{arglist} = $self->make_args($arguments); + $arguments = validate_string($arguments); - # execute all registered interpreters - my $result; - foreach my $func (@{$self->{handlers}}) { - $result = &{$func->{subref}}($stuff); - last if defined $result; - # reset any manipulated arguments - $stuff->{arguments} = $stuff->{original_arguments}; + # set arguments as a plain string + $stuff->{arguments} = $arguments; delete $stuff->{args_utf8}; - } - return $result; + + # set arguments as an array + $stuff->{arglist} = $self->make_args($arguments); + + # execute all registered interpreters + my $result; + foreach my $func (@{$self->{handlers}}) { + $result = &{$func->{subref}}($stuff); + last if defined $result; + + # reset any manipulated arguments + $stuff->{arguments} = $stuff->{original_arguments}; + delete $stuff->{args_utf8}; + } + return $result; } # extracts a bracketed substring, gracefully handling unbalanced quotes # or brackets. opening and closing brackets may each be more than one character. # optional prefix may be or begin with a character group. sub extract_bracketed { - my ($self, $string, $open_bracket, $close_bracket, $optional_prefix, $allow_whitespace) = @_; + my ($self, $string, $open_bracket, $close_bracket, $optional_prefix, $allow_whitespace) = @_; - $open_bracket = '{' if not defined $open_bracket; - $close_bracket = '}' if not defined $close_bracket; - $optional_prefix = '' if not defined $optional_prefix; - $allow_whitespace = 0 if not defined $allow_whitespace; + $open_bracket = '{' if not defined $open_bracket; + $close_bracket = '}' if not defined $close_bracket; + $optional_prefix = '' if not defined $optional_prefix; + $allow_whitespace = 0 if not defined $allow_whitespace; - my @prefix_group; + my @prefix_group; - if ($optional_prefix =~ s/^\[(.*?)\]//) { - @prefix_group = split //, $1; - } + if ($optional_prefix =~ s/^\[(.*?)\]//) { @prefix_group = split //, $1; } - my @prefixes = split //, $optional_prefix; - my @opens = split //, $open_bracket; - my @closes = split //, $close_bracket; + my @prefixes = split //, $optional_prefix; + my @opens = split //, $open_bracket; + my @closes = split //, $close_bracket; - my $prefix_index = 0; - my $open_index = 0; - my $close_index = 0; + my $prefix_index = 0; + my $open_index = 0; + my $close_index = 0; - my $result = ''; - my $rest = ''; - my $extracting = 0; - my $extracted = 0; - my $escaped = 0; - my $token = ''; - my $ch = ' '; - my $last_ch; - my $i = 0; - my $bracket_pos; - my $bracket_level = 0; - my $prefix_group_match = @prefix_group ? 0 : 1; - my $prefix_match = @prefixes ? 0 : 1; - my $match = 0; + my $result = ''; + my $rest = ''; + my $extracting = 0; + my $extracted = 0; + my $escaped = 0; + my $token = ''; + my $ch = ' '; + my $last_ch; + my $i = 0; + my $bracket_pos; + my $bracket_level = 0; + my $prefix_group_match = @prefix_group ? 0 : 1; + my $prefix_match = @prefixes ? 0 : 1; + my $match = 0; - my @chars = split //, $string; + my @chars = split //, $string; - my $state = 'prefixgroup'; + my $state = 'prefixgroup'; - while (1) { - $last_ch = $ch; + while (1) { + $last_ch = $ch; - if ($i >= @chars) { - if ($extracting) { - # reached end, but unbalanced brackets... reset to beginning and ignore them - $i = $bracket_pos; - $bracket_level = 0; - $state = 'prefixgroup'; - $extracting = 0; - $last_ch = ' '; - $token = ''; - $result = ''; - } else { - # add final token and exit - $rest .= $token if $extracted; - last; - } - } + if ($i >= @chars) { + if ($extracting) { - $ch = $chars[$i++]; - - if ($escaped) { - $token .= "\\$ch" if $extracting or $extracted; - $escaped = 0; - next; - } - - if ($ch eq '\\') { - $escaped = 1; - next; - } - - if (not $extracted) { - if ($state eq 'prefixgroup' and @prefix_group and not $extracting) { - foreach my $prefix_ch (@prefix_group) { - if ($ch eq $prefix_ch) { - $prefix_group_match = 1; - $state = 'prefixes'; - last; - } else { - $prefix_group_match = 0; - } - } - next if $prefix_group_match; - } elsif ($state eq 'prefixgroup' and not @prefix_group) { - $state = 'prefixes'; - $prefix_index = 0; - } - - if ($state eq 'prefixes') { - if (@prefixes and $ch eq $prefixes[$prefix_index]) { - $token .= $ch if $extracting; - $prefix_match = 1; - $prefix_index++; - $state = 'openbracket'; - next; - } elsif ($state eq 'prefixes' and not @prefixes) { - $state = 'openbracket'; - } - } - - if ($extracting or ($state eq 'openbracket' and $prefix_group_match and $prefix_match)) { - $prefix_index = 0; - if ($ch eq $opens[$open_index]) { - $match = 1; - $open_index++; - } else { - if ($allow_whitespace and $ch eq ' ' and not $extracting) { - next; - } elsif (not $extracting) { - $state = 'prefixgroup'; - next; - } - } - } - - if ($match) { - $state = 'prefixgroup'; - $prefix_group_match = 0 unless not @prefix_group; - $prefix_match = 0 unless not @prefixes; - $match = 0; - $bracket_pos = $i if not $extracting; - if ($open_index == @opens) { - $extracting = 1; - $token .= $ch if $bracket_level > 0; - $bracket_level++; - $open_index = 0; - } - next; - } else { - $open_index = 0; - } - - if ($ch eq $closes[$close_index]) { - if ($extracting or $extracted) { - $close_index++; - if ($close_index == @closes) { - $close_index = 0; - if (--$bracket_level == 0) { - $extracting = 0; - $extracted = 1; - $result .= $token; - $token = ''; + # reached end, but unbalanced brackets... reset to beginning and ignore them + $i = $bracket_pos; + $bracket_level = 0; + $state = 'prefixgroup'; + $extracting = 0; + $last_ch = ' '; + $token = ''; + $result = ''; } else { - $token .= $ch; + + # add final token and exit + $rest .= $token if $extracted; + last; } - } } - next; - } else { - $close_index = 0; - } + + $ch = $chars[$i++]; + + if ($escaped) { + $token .= "\\$ch" if $extracting or $extracted; + $escaped = 0; + next; + } + + if ($ch eq '\\') { + $escaped = 1; + next; + } + + if (not $extracted) { + if ($state eq 'prefixgroup' and @prefix_group and not $extracting) { + foreach my $prefix_ch (@prefix_group) { + if ($ch eq $prefix_ch) { + $prefix_group_match = 1; + $state = 'prefixes'; + last; + } else { + $prefix_group_match = 0; + } + } + next if $prefix_group_match; + } elsif ($state eq 'prefixgroup' and not @prefix_group) { + $state = 'prefixes'; + $prefix_index = 0; + } + + if ($state eq 'prefixes') { + if (@prefixes and $ch eq $prefixes[$prefix_index]) { + $token .= $ch if $extracting; + $prefix_match = 1; + $prefix_index++; + $state = 'openbracket'; + next; + } elsif ($state eq 'prefixes' and not @prefixes) { + $state = 'openbracket'; + } + } + + if ($extracting or ($state eq 'openbracket' and $prefix_group_match and $prefix_match)) { + $prefix_index = 0; + if ($ch eq $opens[$open_index]) { + $match = 1; + $open_index++; + } else { + if ($allow_whitespace and $ch eq ' ' and not $extracting) { next; } + elsif (not $extracting) { + $state = 'prefixgroup'; + next; + } + } + } + + if ($match) { + $state = 'prefixgroup'; + $prefix_group_match = 0 unless not @prefix_group; + $prefix_match = 0 unless not @prefixes; + $match = 0; + $bracket_pos = $i if not $extracting; + if ($open_index == @opens) { + $extracting = 1; + $token .= $ch if $bracket_level > 0; + $bracket_level++; + $open_index = 0; + } + next; + } else { + $open_index = 0; + } + + if ($ch eq $closes[$close_index]) { + if ($extracting or $extracted) { + $close_index++; + if ($close_index == @closes) { + $close_index = 0; + if (--$bracket_level == 0) { + $extracting = 0; + $extracted = 1; + $result .= $token; + $token = ''; + } else { + $token .= $ch; + } + } + } + next; + } else { + $close_index = 0; + } + } + + if ($extracting or $extracted) { $token .= $ch; } } - if ($extracting or $extracted) { - $token .= $ch; - } - } - - return ($result, $rest); + return ($result, $rest); } # splits line into quoted arguments while preserving quotes. @@ -510,578 +502,561 @@ sub extract_bracketed { # handles unbalanced quotes gracefully by treating them as # part of the argument they were found within. sub split_line { - my ($self, $line, %opts) = @_; + my ($self, $line, %opts) = @_; - my %default_opts = ( - strip_quotes => 0, - keep_spaces => 0, - preserve_escapes => 1, - ); + my %default_opts = ( + strip_quotes => 0, + keep_spaces => 0, + preserve_escapes => 1, + ); - %opts = (%default_opts, %opts); + %opts = (%default_opts, %opts); - my @chars = split //, $line; + my @chars = split //, $line; - my @args; - my $escaped = 0; - my $quote; - my $token = ''; - my $last_token = ''; - my $ch = ' '; - my $last_ch; - my $next_ch; - my $i = 0; - my $pos; - my $ignore_quote = 0; - my $spaces = 0; + my @args; + my $escaped = 0; + my $quote; + my $token = ''; + my $last_token = ''; + my $ch = ' '; + my $last_ch; + my $next_ch; + my $i = 0; + my $pos; + my $ignore_quote = 0; + my $spaces = 0; - while (1) { - $last_ch = $ch; + while (1) { + $last_ch = $ch; - if ($i >= @chars) { - if (defined $quote) { - # reached end, but unbalanced quote... reset to beginning of quote and ignore it - $i = $pos; - $ignore_quote = 1; - $quote = undef; - $last_ch = ' '; - $token = $last_token; - } else { - # add final token and exit - push @args, $token if length $token; - last; - } - } + if ($i >= @chars) { + if (defined $quote) { - $ch = $chars[$i++]; - $next_ch = $chars[$i]; + # reached end, but unbalanced quote... reset to beginning of quote and ignore it + $i = $pos; + $ignore_quote = 1; + $quote = undef; + $last_ch = ' '; + $token = $last_token; + } else { - $spaces = 0 if $ch ne ' '; + # add final token and exit + push @args, $token if length $token; + last; + } + } + + $ch = $chars[$i++]; + $next_ch = $chars[$i]; + + $spaces = 0 if $ch ne ' '; + + if ($escaped) { + if ($opts{preserve_escapes}) { $token .= "\\$ch"; } + else { $token .= $ch; } + $escaped = 0; + next; + } + + if ($ch eq '\\') { + $escaped = 1; + next; + } + + if (defined $quote) { + if ($ch eq $quote and (not defined $next_ch or $next_ch =~ /[\s,:;})\].+=]/)) { + + # closing quote + $token .= $ch unless $opts{strip_quotes}; + push @args, $token; + $quote = undef; + $token = ''; + } else { + + # still within quoted argument + $token .= $ch; + } + next; + } + + if (($last_ch =~ /[\s:{(\[.+=]/) and not defined $quote and ($ch eq "'" or $ch eq '"')) { + if ($ignore_quote) { + + # treat unbalanced quote as part of this argument + $token .= $ch; + $ignore_quote = 0; + } else { + + # begin potential quoted argument + $pos = $i - 1; + $quote = $ch; + $last_token = $token; + $token .= $ch unless $opts{strip_quotes}; + } + next; + } + + if ($ch eq ' ' or $ch eq "\n" or $ch eq "\t") { + if (++$spaces > 1 and $opts{keep_spaces}) { + $token .= $ch; + next; + } else { + push @args, $token if length $token; + $token = ''; + next; + } + } - if ($escaped) { - if ($opts{preserve_escapes}) { - $token .= "\\$ch"; - } else { $token .= $ch; - } - $escaped = 0; - next; } - if ($ch eq '\\') { - $escaped = 1; - next; - } - - if (defined $quote) { - if ($ch eq $quote and (not defined $next_ch or $next_ch =~ /[\s,:;})\].+=]/)) { - # closing quote - $token .= $ch unless $opts{strip_quotes}; - push @args, $token; - $quote = undef; - $token = ''; - } else { - # still within quoted argument - $token .= $ch; - } - next; - } - - if (($last_ch =~ /[\s:{(\[.+=]/) and not defined $quote and ($ch eq "'" or $ch eq '"')) { - if ($ignore_quote) { - # treat unbalanced quote as part of this argument - $token .= $ch; - $ignore_quote = 0; - } else { - # begin potential quoted argument - $pos = $i - 1; - $quote = $ch; - $last_token = $token; - $token .= $ch unless $opts{strip_quotes}; - } - next; - } - - if ($ch eq ' ' or $ch eq "\n" or $ch eq "\t") { - if (++$spaces > 1 and $opts{keep_spaces}) { - $token .= $ch; - next; - } else { - push @args, $token if length $token; - $token = ''; - next; - } - } - - $token .= $ch; - } - - return @args; + return @args; } # creates an array of arguments from a string sub make_args { - my ($self, $string) = @_; + my ($self, $string) = @_; - my @args = $self->split_line($string, keep_spaces => 1); + my @args = $self->split_line($string, keep_spaces => 1); - my @arglist; - my @arglist_unstripped; + my @arglist; + my @arglist_unstripped; - while (@args) { - my $arg = shift @args; + while (@args) { + my $arg = shift @args; - # add argument with quotes and spaces preserved - push @arglist_unstripped, $arg; + # add argument with quotes and spaces preserved + push @arglist_unstripped, $arg; - # strip quotes from argument - if ($arg =~ m/^'.*'$/) { - $arg =~ s/^'//; - $arg =~ s/'$//; - } elsif ($arg =~ m/^".*"$/) { - $arg =~ s/^"//; - $arg =~ s/"$//; + # strip quotes from argument + if ($arg =~ m/^'.*'$/) { + $arg =~ s/^'//; + $arg =~ s/'$//; + } elsif ($arg =~ m/^".*"$/) { + $arg =~ s/^"//; + $arg =~ s/"$//; + } + + # strip leading spaces from argument + $arg =~ s/^\s+//; + + # add stripped argument + push @arglist, $arg; } - # strip leading spaces from argument - $arg =~ s/^\s+//; - - # add stripped argument - push @arglist, $arg; - } - - # copy unstripped arguments to end of arglist - push @arglist, @arglist_unstripped; - return \@arglist; + # copy unstripped arguments to end of arglist + push @arglist, @arglist_unstripped; + return \@arglist; } # returns size of array of arguments sub arglist_size { - my ($self, $args) = @_; - return @$args / 2; + my ($self, $args) = @_; + return @$args / 2; } # unshifts new argument to front sub unshift_arg { - my ($self, $args, $arg) = @_; - splice @$args, @$args / 2, 0, $arg; # add quoted argument - unshift @$args, $arg; # add first argument - return @$args; + my ($self, $args, $arg) = @_; + splice @$args, @$args / 2, 0, $arg; # add quoted argument + unshift @$args, $arg; # add first argument + return @$args; } # shifts first argument off array of arguments sub shift_arg { - my ($self, $args) = @_; - return undef if not @$args; - splice @$args, @$args / 2, 1; # remove original quoted argument - return shift @$args; + my ($self, $args) = @_; + return undef if not @$args; + splice @$args, @$args / 2, 1; # remove original quoted argument + return shift @$args; } # returns list of unquoted arguments sub unquoted_args { - my ($self, $args) = @_; - return undef if not @$args; - return @$args[0 .. @$args / 2 - 1]; + my ($self, $args) = @_; + return undef if not @$args; + return @$args[0 .. @$args / 2 - 1]; } # splits array of arguments into array with overflow arguments filling up last position # split_args(qw/dog cat bird hamster/, 3) => ("dog", "cat", "bird hamster") sub split_args { - my ($self, $args, $count, $offset, $preserve_quotes) = @_; - my @result; - my $max = $self->arglist_size($args); + my ($self, $args, $count, $offset, $preserve_quotes) = @_; + my @result; + my $max = $self->arglist_size($args); - $preserve_quotes //= 0; + $preserve_quotes //= 0; - my $i = $offset // 0; - unless ($count == 1) { - do { - my $arg = $args->[$i++]; - push @result, $arg; - } while (--$count > 1 and $i < $max); - } + my $i = $offset // 0; + unless ($count == 1) { + do { + my $arg = $args->[$i++]; + push @result, $arg; + } while (--$count > 1 and $i < $max); + } - # join the get rest as a string - my $rest; - if ($preserve_quotes) { - # get from second half of args, which contains quotes - $rest = join ' ', @$args[@$args / 2 + $i .. @$args - 1]; - } else { - $rest = join ' ', @$args[$i .. $max - 1]; - } - push @result, $rest if length $rest; - return @result; + # join the get rest as a string + my $rest; + if ($preserve_quotes) { + + # get from second half of args, which contains quotes + $rest = join ' ', @$args[@$args / 2 + $i .. @$args - 1]; + } else { + $rest = join ' ', @$args[$i .. $max - 1]; + } + push @result, $rest if length $rest; + return @result; } # lowercases array of arguments sub lc_args { - my ($self, $args) = @_; - for (my $i = 0; $i < @$args; $i++) { - $args->[$i] = lc $args->[$i]; - } + my ($self, $args) = @_; + for (my $i = 0; $i < @$args; $i++) { $args->[$i] = lc $args->[$i]; } } sub truncate_result { - my ($self, $from, $nick, $text, $original_result, $result, $paste) = @_; - my $max_msg_len = $self->{pbot}->{registry}->get_value('irc', 'max_msg_len'); + my ($self, $from, $nick, $text, $original_result, $result, $paste) = @_; + my $max_msg_len = $self->{pbot}->{registry}->get_value('irc', 'max_msg_len'); - if (length $result > $max_msg_len) { - my $link; - if ($paste) { - $original_result = substr $original_result, 0, 8000; - $link = $self->{pbot}->{webpaste}->paste("[" . (defined $from ? $from : "stdin") . "] <$nick> $text\n\n$original_result"); - } else { - $link = 'undef'; + if (length $result > $max_msg_len) { + my $link; + if ($paste) { + $original_result = substr $original_result, 0, 8000; + $link = $self->{pbot}->{webpaste}->paste("[" . (defined $from ? $from : "stdin") . "] <$nick> $text\n\n$original_result"); + } else { + $link = 'undef'; + } + + my $trunc = "... [truncated; "; + if ($link =~ m/^http/) { $trunc .= "see $link for full text.]"; } + else { $trunc .= "$link]"; } + + $self->{pbot}->{logger}->log("Message truncated -- pasted to $link\n") if $paste; + + my $trunc_len = length $result < $max_msg_len ? length $result : $max_msg_len; + $result = substr($result, 0, $trunc_len); + substr($result, $trunc_len - length $trunc) = $trunc; } - my $trunc = "... [truncated; "; - if ($link =~ m/^http/) { - $trunc .= "see $link for full text.]"; - } else { - $trunc .= "$link]"; - } - - $self->{pbot}->{logger}->log("Message truncated -- pasted to $link\n") if $paste; - - my $trunc_len = length $result < $max_msg_len ? length $result : $max_msg_len; - $result = substr($result, 0, $trunc_len); - substr($result, $trunc_len - length $trunc) = $trunc; - } - - return $result; + return $result; } sub handle_result { - my ($self, $stuff, $result) = @_; - $result = $stuff->{result} if not defined $result; - $stuff->{preserve_whitespace} = 0 if not defined $stuff->{preserve_whitespace}; + my ($self, $stuff, $result) = @_; + $result = $stuff->{result} if not defined $result; + $stuff->{preserve_whitespace} = 0 if not defined $stuff->{preserve_whitespace}; - if ($self->{pbot}->{registry}->get_value('general', 'debugcontext') and length $stuff->{result}) { - use Data::Dumper; - $Data::Dumper::Sortkeys = 1; - $self->{pbot}->{logger}->log("Interpreter::handle_result [$result]\n"); - $self->{pbot}->{logger}->log(Dumper $stuff); - } - - return 0 if not defined $result or length $result == 0; - - if ($result =~ s#^(/say|/me) ##) { - $stuff->{prepend} = $1; - } elsif ($result =~ s#^(/msg \S+) ##) { - $stuff->{prepend} = $1; - } - - if ($stuff->{pipe}) { - my ($pipe, $pipe_rest) = (delete $stuff->{pipe}, delete $stuff->{pipe_rest}); - if (not $stuff->{alldone}) { - $stuff->{command} = "$pipe $result $pipe_rest"; - $result = $self->interpret($stuff); - $stuff->{result} = $result; - } - $self->handle_result($stuff, $result); - return 0; - } - - if (exists $stuff->{subcmd}) { - my $command = pop @{$stuff->{subcmd}}; - - if (@{$stuff->{subcmd}} == 0 or $stuff->{alldone}) { - delete $stuff->{subcmd}; + if ($self->{pbot}->{registry}->get_value('general', 'debugcontext') and length $stuff->{result}) { + use Data::Dumper; + $Data::Dumper::Sortkeys = 1; + $self->{pbot}->{logger}->log("Interpreter::handle_result [$result]\n"); + $self->{pbot}->{logger}->log(Dumper $stuff); } - $command =~ s/&\{subcmd\}/$result/; + return 0 if not defined $result or length $result == 0; - if (not $stuff->{alldone}) { - $stuff->{command} = $command; - $result = $self->interpret($stuff); - $stuff->{result}= $result; + if ($result =~ s#^(/say|/me) ##) { $stuff->{prepend} = $1; } + elsif ($result =~ s#^(/msg \S+) ##) { $stuff->{prepend} = $1; } + + if ($stuff->{pipe}) { + my ($pipe, $pipe_rest) = (delete $stuff->{pipe}, delete $stuff->{pipe_rest}); + if (not $stuff->{alldone}) { + $stuff->{command} = "$pipe $result $pipe_rest"; + $result = $self->interpret($stuff); + $stuff->{result} = $result; + } + $self->handle_result($stuff, $result); + return 0; } - $self->handle_result($stuff); - return 0; - } - if ($stuff->{prepend}) { - $result = "$stuff->{prepend} $result"; - } + if (exists $stuff->{subcmd}) { + my $command = pop @{$stuff->{subcmd}}; - if ($stuff->{command_split}) { - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - $stuff->{command} = delete $stuff->{command_split}; - $result =~ s#^/say #\n#i; - $result =~ s#^/me #\n* $botnick #i; - if (not length $stuff->{split_result}) { - $result =~ s/^\n//; - $stuff->{split_result} = $result; - } else { - $stuff->{split_result} .= $result; + if (@{$stuff->{subcmd}} == 0 or $stuff->{alldone}) { delete $stuff->{subcmd}; } + + $command =~ s/&\{subcmd\}/$result/; + + if (not $stuff->{alldone}) { + $stuff->{command} = $command; + $result = $self->interpret($stuff); + $stuff->{result} = $result; + } + $self->handle_result($stuff); + return 0; } - $result = $self->interpret($stuff); - $self->handle_result($stuff, $result); - return 0; - } - if ($stuff->{split_result}) { - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - $result =~ s#^/say #\n#i; - $result =~ s#^/me #\n* $botnick #i; - $result = $stuff->{split_result} . $result; - } + if ($stuff->{prepend}) { $result = "$stuff->{prepend} $result"; } - my $original_result = $result; + if ($stuff->{command_split}) { + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + $stuff->{command} = delete $stuff->{command_split}; + $result =~ s#^/say #\n#i; + $result =~ s#^/me #\n* $botnick #i; + if (not length $stuff->{split_result}) { + $result =~ s/^\n//; + $stuff->{split_result} = $result; + } else { + $stuff->{split_result} .= $result; + } + $result = $self->interpret($stuff); + $self->handle_result($stuff, $result); + return 0; + } - my $use_output_queue = 0; + if ($stuff->{split_result}) { + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + $result =~ s#^/say #\n#i; + $result =~ s#^/me #\n* $botnick #i; + $result = $stuff->{split_result} . $result; + } - if (defined $stuff->{command}) { - my $cmdlist = $self->make_args($stuff->{command}); - my ($cmd, $args) = $self->split_args($cmdlist, 2, 0, 1); - if (not $self->{pbot}->{commands}->exists($cmd)) { - my ($chan, $trigger) = $self->{pbot}->{factoids}->find_factoid($stuff->{from}, $cmd, arguments => $args, exact_channel => 1, exact_trigger => 0, find_alias => 1); - if (defined $trigger) { - if ($stuff->{preserve_whitespace} == 0) { - $stuff->{preserve_whitespace} = $self->{pbot}->{factoids}->{factoids}->get_data($chan, $trigger, 'preserve_whitespace'); - $stuff->{preserve_whitespace} = 0 if not defined $stuff->{preserve_whitespace}; + my $original_result = $result; + + my $use_output_queue = 0; + + if (defined $stuff->{command}) { + my $cmdlist = $self->make_args($stuff->{command}); + my ($cmd, $args) = $self->split_args($cmdlist, 2, 0, 1); + if (not $self->{pbot}->{commands}->exists($cmd)) { + my ($chan, $trigger) = $self->{pbot}->{factoids}->find_factoid($stuff->{from}, $cmd, arguments => $args, exact_channel => 1, exact_trigger => 0, find_alias => 1); + if (defined $trigger) { + if ($stuff->{preserve_whitespace} == 0) { + $stuff->{preserve_whitespace} = $self->{pbot}->{factoids}->{factoids}->get_data($chan, $trigger, 'preserve_whitespace'); + $stuff->{preserve_whitespace} = 0 if not defined $stuff->{preserve_whitespace}; + } + + $use_output_queue = $self->{pbot}->{factoids}->{factoids}->get_data($chan, $trigger, 'use_output_queue'); + $use_output_queue = 0 if not defined $use_output_queue; + } + } + } + + my $preserve_newlines = $self->{pbot}->{registry}->get_value($stuff->{from}, 'preserve_newlines'); + + $result =~ s/[\n\r]/ /g unless $preserve_newlines; + $result =~ s/[ \t]+/ /g unless $stuff->{preserve_whitespace}; + + my $max_lines = $self->{pbot}->{registry}->get_value($stuff->{from}, 'max_newlines'); + $max_lines = 4 if not defined $max_lines; + my $lines = 0; + + my $stripped_line; + foreach my $line (split /[\n\r]+/, $result) { + $stripped_line = $line; + $stripped_line =~ s/^\s+//; + $stripped_line =~ s/\s+$//; + next if not length $stripped_line; + + if (++$lines >= $max_lines) { + my $link = $self->{pbot}->{webpaste}->paste("[" . (defined $stuff->{from} ? $stuff->{from} : "stdin") . "] <$stuff->{nick}> $stuff->{text}\n\n$original_result"); + if ($use_output_queue) { + my $message = { + nick => $stuff->{nick}, user => $stuff->{user}, host => $stuff->{host}, command => $stuff->{command}, + message => "And that's all I have to say about that. See $link for full text.", + checkflood => 1 + }; + $self->add_message_to_output_queue($stuff->{from}, $message, 0); + } else { + $self->{pbot}->{conn}->privmsg($stuff->{from}, "And that's all I have to say about that. See $link for full text.") unless $stuff->{from} eq 'stdin@pbot'; + } + last; } - $use_output_queue = $self->{pbot}->{factoids}->{factoids}->get_data($chan, $trigger, 'use_output_queue'); - $use_output_queue = 0 if not defined $use_output_queue; - } + if ($preserve_newlines) { $line = $self->truncate_result($stuff->{from}, $stuff->{nick}, $stuff->{text}, $line, $line, 1); } + else { $line = $self->truncate_result($stuff->{from}, $stuff->{nick}, $stuff->{text}, $original_result, $line, 1); } + + if ($use_output_queue) { + my $delay = rand(10) + 5; + my $message = { + nick => $stuff->{nick}, user => $stuff->{user}, host => $stuff->{host}, command => $stuff->{command}, + message => $line, checkflood => 1 + }; + $self->add_message_to_output_queue($stuff->{from}, $message, $delay); + $delay = duration($delay); + $self->{pbot}->{logger}->log("($delay delay) $line\n"); + } else { + $stuff->{line} = $line; + $self->output_result($stuff); + $self->{pbot}->{logger}->log("$line\n"); + } } - } - - my $preserve_newlines = $self->{pbot}->{registry}->get_value($stuff->{from}, 'preserve_newlines'); - - $result =~ s/[\n\r]/ /g unless $preserve_newlines; - $result =~ s/[ \t]+/ /g unless $stuff->{preserve_whitespace}; - - my $max_lines = $self->{pbot}->{registry}->get_value($stuff->{from}, 'max_newlines'); - $max_lines = 4 if not defined $max_lines; - my $lines = 0; - - my $stripped_line; - foreach my $line (split /[\n\r]+/, $result) { - $stripped_line = $line; - $stripped_line =~ s/^\s+//; - $stripped_line =~ s/\s+$//; - next if not length $stripped_line; - - if (++$lines >= $max_lines) { - my $link = $self->{pbot}->{webpaste}->paste("[" . (defined $stuff->{from} ? $stuff->{from} : "stdin") . "] <$stuff->{nick}> $stuff->{text}\n\n$original_result"); - if ($use_output_queue) { - my $message = { - nick => $stuff->{nick}, user => $stuff->{user}, host => $stuff->{host}, command => $stuff->{command}, - message => "And that's all I have to say about that. See $link for full text.", - checkflood => 1 - }; - $self->add_message_to_output_queue($stuff->{from}, $message, 0); - } else { - $self->{pbot}->{conn}->privmsg($stuff->{from}, "And that's all I have to say about that. See $link for full text.") unless $stuff->{from} eq 'stdin@pbot'; - } - last; - } - - if ($preserve_newlines) { - $line = $self->truncate_result($stuff->{from}, $stuff->{nick}, $stuff->{text}, $line, $line, 1); - } else { - $line = $self->truncate_result($stuff->{from}, $stuff->{nick}, $stuff->{text}, $original_result, $line, 1); - } - - if ($use_output_queue) { - my $delay = rand (10) + 5; - my $message = { - nick => $stuff->{nick}, user => $stuff->{user}, host => $stuff->{host}, command => $stuff->{command}, - message => $line, checkflood => 1 - }; - $self->add_message_to_output_queue($stuff->{from}, $message, $delay); - $delay = duration($delay); - $self->{pbot}->{logger}->log("($delay delay) $line\n"); - } else { - $stuff->{line} = $line; - $self->output_result($stuff); - $self->{pbot}->{logger}->log("$line\n"); - } - } - $self->{pbot}->{logger}->log("---------------------------------------------\n"); - return 1; + $self->{pbot}->{logger}->log("---------------------------------------------\n"); + return 1; } sub dehighlight_nicks { - my ($self, $line, $channel) = @_; - return $line if $self->{pbot}->{registry}->get_value('general', 'no_dehighlight_nicks'); - my @nicks = $self->{pbot}->{nicklist}->get_nicks($channel); - return $line if not @nicks; - foreach my $nick (@nicks) { - $nick = quotemeta $nick; - my $const_line = $line; - while ($const_line =~ m/(?{pbot}->{registry}->get_value('general', 'no_dehighlight_nicks'); + my @nicks = $self->{pbot}->{nicklist}->get_nicks($channel); + return $line if not @nicks; + foreach my $nick (@nicks) { + $nick = quotemeta $nick; + my $const_line = $line; + while ($const_line =~ m/(?{pbot}, $self->{pbot}->{registry}->get_value('irc', 'botnick')); + my ($self, $stuff) = @_; + my ($pbot, $botnick) = ($self->{pbot}, $self->{pbot}->{registry}->get_value('irc', 'botnick')); - if ($self->{pbot}->{registry}->get_value('general', 'debugcontext')) { - use Data::Dumper; - $Data::Dumper::Sortkeys = 1; - $self->{pbot}->{logger}->log("Interpreter::output_result\n"); - $self->{pbot}->{logger}->log(Dumper $stuff); - } - - my $line = $stuff->{line}; - - return if not defined $line or not length $line; - return 0 if $stuff->{from} eq 'stdin@pbot'; - - $line = $self->dehighlight_nicks($line, $stuff->{from}) if $stuff->{from} =~ /^#/ and $line !~ /^\/msg\s+/i; - - if ($line =~ s/^\/say\s+//i) { - if (defined $stuff->{nickoverride} and ($stuff->{no_nickoverride} == 0 or $stuff->{force_nickoverride} == 1)) { - $line = "$stuff->{nickoverride}: $line"; + if ($self->{pbot}->{registry}->get_value('general', 'debugcontext')) { + use Data::Dumper; + $Data::Dumper::Sortkeys = 1; + $self->{pbot}->{logger}->log("Interpreter::output_result\n"); + $self->{pbot}->{logger}->log(Dumper $stuff); } - $pbot->{conn}->privmsg($stuff->{from}, $line) if defined $stuff->{from} && $stuff->{from} ne $botnick; - $pbot->{antiflood}->check_flood($stuff->{from}, $botnick, $pbot->{registry}->get_value('irc', 'username'), 'pbot', $line, 0, 0, 0) if $stuff->{checkflood}; - } elsif ($line =~ s/^\/me\s+//i) { + + my $line = $stuff->{line}; + + return if not defined $line or not length $line; + return 0 if $stuff->{from} eq 'stdin@pbot'; + + $line = $self->dehighlight_nicks($line, $stuff->{from}) if $stuff->{from} =~ /^#/ and $line !~ /^\/msg\s+/i; + + if ($line =~ s/^\/say\s+//i) { + if (defined $stuff->{nickoverride} and ($stuff->{no_nickoverride} == 0 or $stuff->{force_nickoverride} == 1)) { $line = "$stuff->{nickoverride}: $line"; } + $pbot->{conn}->privmsg($stuff->{from}, $line) if defined $stuff->{from} && $stuff->{from} ne $botnick; + $pbot->{antiflood}->check_flood($stuff->{from}, $botnick, $pbot->{registry}->get_value('irc', 'username'), 'pbot', $line, 0, 0, 0) if $stuff->{checkflood}; + } elsif ($line =~ s/^\/me\s+//i) { + =cut if (defined $stuff->{nickoverride}) { $line = "$line (for $stuff->{nickoverride})"; } =cut - $pbot->{conn}->me($stuff->{from}, $line) if defined $stuff->{from} && $stuff->{from} ne $botnick; - $pbot->{antiflood}->check_flood($stuff->{from}, $botnick, $pbot->{registry}->get_value('irc', 'username'), 'pbot', '/me ' . $line, 0, 0, 0) if $stuff->{checkflood}; - } elsif ($line =~ s/^\/msg\s+([^\s]+)\s+//i) { - my $to = $1; - if ($to =~ /,/) { - $pbot->{logger}->log("[HACK] Possible HACK ATTEMPT /msg multiple users: [$stuff->{nick}!$stuff->{user}\@$stuff->{host}] [$stuff->{command}] [$line]\n"); - } elsif ($to =~ /.*serv(?:@.*)?$/i) { - $pbot->{logger}->log("[HACK] Possible HACK ATTEMPT /msg *serv: [$stuff->{nick}!$stuff->{user}\@$stuff->{host}] [$stuff->{command}] [$line]\n"); - } elsif ($line =~ s/^\/me\s+//i) { + + $pbot->{conn}->me($stuff->{from}, $line) if defined $stuff->{from} && $stuff->{from} ne $botnick; + $pbot->{antiflood}->check_flood($stuff->{from}, $botnick, $pbot->{registry}->get_value('irc', 'username'), 'pbot', '/me ' . $line, 0, 0, 0) if $stuff->{checkflood}; + } elsif ($line =~ s/^\/msg\s+([^\s]+)\s+//i) { + my $to = $1; + if ($to =~ /,/) { + $pbot->{logger}->log("[HACK] Possible HACK ATTEMPT /msg multiple users: [$stuff->{nick}!$stuff->{user}\@$stuff->{host}] [$stuff->{command}] [$line]\n"); + } elsif ($to =~ /.*serv(?:@.*)?$/i) { + $pbot->{logger}->log("[HACK] Possible HACK ATTEMPT /msg *serv: [$stuff->{nick}!$stuff->{user}\@$stuff->{host}] [$stuff->{command}] [$line]\n"); + } elsif ($line =~ s/^\/me\s+//i) { + =cut if (defined $stuff->{nickoverride}) { $line = "$line (for $stuff->{nickoverride})"; } =cut - $pbot->{conn}->me($to, $line) if $to ne $botnick; - $pbot->{antiflood}->check_flood($to, $botnick, $pbot->{registry}->get_value('irc', 'username'), 'pbot', '/me ' . $line, 0, 0, 0) if $stuff->{checkflood}; + + $pbot->{conn}->me($to, $line) if $to ne $botnick; + $pbot->{antiflood}->check_flood($to, $botnick, $pbot->{registry}->get_value('irc', 'username'), 'pbot', '/me ' . $line, 0, 0, 0) if $stuff->{checkflood}; + } else { + $line =~ s/^\/say\s+//i; + if (defined $stuff->{nickoverride} and ($stuff->{no_nickoverride} == 0 or $stuff->{force_nickoverride} == 1)) { $line = "$stuff->{nickoverride}: $line"; } + $pbot->{conn}->privmsg($to, $line) if $to ne $botnick; + $pbot->{antiflood}->check_flood($to, $botnick, $pbot->{registry}->get_value('irc', 'username'), 'pbot', $line, 0, 0, 0) if $stuff->{checkflood}; + } } else { - $line =~ s/^\/say\s+//i; - if (defined $stuff->{nickoverride} and ($stuff->{no_nickoverride} == 0 or $stuff->{force_nickoverride} == 1)) { - $line = "$stuff->{nickoverride}: $line"; - } - $pbot->{conn}->privmsg($to, $line) if $to ne $botnick; - $pbot->{antiflood}->check_flood($to, $botnick, $pbot->{registry}->get_value('irc', 'username'), 'pbot', $line, 0, 0, 0) if $stuff->{checkflood}; + if (defined $stuff->{nickoverride} and ($stuff->{no_nickoverride} == 0 or $stuff->{force_nickoverride} == 1)) { $line = "$stuff->{nickoverride}: $line"; } + $pbot->{conn}->privmsg($stuff->{from}, $line) if defined $stuff->{from} && $stuff->{from} ne $botnick; + $pbot->{antiflood}->check_flood($stuff->{from}, $botnick, $pbot->{registry}->get_value('irc', 'username'), 'pbot', $line, 0, 0, 0) if $stuff->{checkflood}; } - } else { - if (defined $stuff->{nickoverride} and ($stuff->{no_nickoverride} == 0 or $stuff->{force_nickoverride} == 1)) { - $line = "$stuff->{nickoverride}: $line"; - } - $pbot->{conn}->privmsg($stuff->{from}, $line) if defined $stuff->{from} && $stuff->{from} ne $botnick; - $pbot->{antiflood}->check_flood($stuff->{from}, $botnick, $pbot->{registry}->get_value('irc', 'username'), 'pbot', $line, 0, 0, 0) if $stuff->{checkflood}; - } } sub add_message_to_output_queue { - my ($self, $channel, $message, $delay) = @_; + my ($self, $channel, $message, $delay) = @_; - if ($delay > 0 and exists $self->{output_queue}->{$channel}) { - my $last_when = $self->{output_queue}->{$channel}->[-1]->{when}; - $message->{when} = $last_when + $delay; - } else { - $message->{when} = gettimeofday + $delay; - } + if ($delay > 0 and exists $self->{output_queue}->{$channel}) { + my $last_when = $self->{output_queue}->{$channel}->[-1]->{when}; + $message->{when} = $last_when + $delay; + } else { + $message->{when} = gettimeofday + $delay; + } - push @{$self->{output_queue}->{$channel}}, $message; + push @{$self->{output_queue}->{$channel}}, $message; - $self->process_output_queue if $delay <= 0; + $self->process_output_queue if $delay <= 0; } sub process_output_queue { - my $self = shift; + my $self = shift; - foreach my $channel (keys %{$self->{output_queue}}) { - for (my $i = 0; $i < @{$self->{output_queue}->{$channel}}; $i++) { - my $message = $self->{output_queue}->{$channel}->[$i]; - if (gettimeofday >= $message->{when}) { - my $stuff = { - from => $channel, - nick => $message->{nick}, - user => $message->{user}, - host => $message->{host}, - line => $message->{message}, - command => $message->{command}, - checkflood => $message->{checkflood} - }; + foreach my $channel (keys %{$self->{output_queue}}) { + for (my $i = 0; $i < @{$self->{output_queue}->{$channel}}; $i++) { + my $message = $self->{output_queue}->{$channel}->[$i]; + if (gettimeofday >= $message->{when}) { + my $stuff = { + from => $channel, + nick => $message->{nick}, + user => $message->{user}, + host => $message->{host}, + line => $message->{message}, + command => $message->{command}, + checkflood => $message->{checkflood} + }; - $self->output_result($stuff); - splice @{$self->{output_queue}->{$channel}}, $i--, 1; - } + $self->output_result($stuff); + splice @{$self->{output_queue}->{$channel}}, $i--, 1; + } + } + + if (not @{$self->{output_queue}->{$channel}}) { delete $self->{output_queue}->{$channel}; } } - - if (not @{$self->{output_queue}->{$channel}}) { - delete $self->{output_queue}->{$channel}; - } - } } sub add_to_command_queue { - my ($self, $channel, $command, $delay) = @_; + my ($self, $channel, $command, $delay) = @_; - $command->{when} = gettimeofday + $delay; + $command->{when} = gettimeofday + $delay; - push @{$self->{command_queue}->{$channel}}, $command; + push @{$self->{command_queue}->{$channel}}, $command; } sub add_botcmd_to_command_queue { - my ($self, $channel, $command, $delay) = @_; + my ($self, $channel, $command, $delay) = @_; - my $botcmd = { - nick => $self->{pbot}->{registry}->get_value('irc', 'botnick'), - user => 'stdin', - host => 'pbot', - command => $command - }; + my $botcmd = { + nick => $self->{pbot}->{registry}->get_value('irc', 'botnick'), + user => 'stdin', + host => 'pbot', + command => $command + }; - $self->add_to_command_queue($channel, $botcmd, $delay); + $self->add_to_command_queue($channel, $botcmd, $delay); } sub process_command_queue { - my $self = shift; + my $self = shift; - foreach my $channel (keys %{$self->{command_queue}}) { - for (my $i = 0; $i < @{$self->{command_queue}->{$channel}}; $i++) { - my $command = $self->{command_queue}->{$channel}->[$i]; - if (gettimeofday >= $command->{when}) { - my $stuff = { - from => $channel, - nick => $command->{nick}, - user => $command->{user}, - host => $command->{host}, - command => $command->{command}, - interpret_depth => 0, - checkflood => 0, - preserve_whitespace => 0 - }; + foreach my $channel (keys %{$self->{command_queue}}) { + for (my $i = 0; $i < @{$self->{command_queue}->{$channel}}; $i++) { + my $command = $self->{command_queue}->{$channel}->[$i]; + if (gettimeofday >= $command->{when}) { + my $stuff = { + from => $channel, + nick => $command->{nick}, + user => $command->{user}, + host => $command->{host}, + command => $command->{command}, + interpret_depth => 0, + checkflood => 0, + preserve_whitespace => 0 + }; - if (exists $command->{'cap-override'}) { - $self->{pbot}->{logger}->log("[command queue] Override command capability with $command->{'cap-override'}\n"); - $stuff->{'cap-override'} = $command->{'cap-override'}; + if (exists $command->{'cap-override'}) { + $self->{pbot}->{logger}->log("[command queue] Override command capability with $command->{'cap-override'}\n"); + $stuff->{'cap-override'} = $command->{'cap-override'}; + } + + my $result = $self->interpret($stuff); + $stuff->{result} = $result; + $self->handle_result($stuff, $result); + splice @{$self->{command_queue}->{$channel}}, $i--, 1; + } } - my $result = $self->interpret($stuff); - $stuff->{result} = $result; - $self->handle_result($stuff, $result); - splice @{$self->{command_queue}->{$channel}}, $i--, 1; - } + if (not @{$self->{command_queue}->{$channel}}) { delete $self->{command_queue}->{$channel}; } } - - if (not @{$self->{command_queue}->{$channel}}) { - delete $self->{command_queue}->{$channel}; - } - } } 1; diff --git a/PBot/LagChecker.pm b/PBot/LagChecker.pm index 1acc04fb..a3ccb931 100644 --- a/PBot/LagChecker.pm +++ b/PBot/LagChecker.pm @@ -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; diff --git a/PBot/Logger.pm b/PBot/Logger.pm index 55dcc49b..302c4742 100644 --- a/PBot/Logger.pm +++ b/PBot/Logger.pm @@ -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; diff --git a/PBot/MessageHistory.pm b/PBot/MessageHistory.pm index c6ab329b..8e97a61a 100644 --- a/PBot/MessageHistory.pm +++ b/PBot/MessageHistory.pm @@ -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 [type]"; - } + if (not $id or not $alias) { return "Usage: link [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 "; - } + if (not $id or not $alias) { return "Usage: unlink "; } - 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] ; -h show hostmasks; -i show ids; -n show nickserv accounts; -g show gecos, -r show relationships"; + my $usage = "Usage: aka [-hingr] ; -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 ] [-t,text,h,history ] [-b,before ] [-a,after ] [-x,context ] [-n,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 ] [-t,text,h,history ] [-b,before ] [-a,after ] [-x,context ] [-n,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; diff --git a/PBot/MessageHistory_SQLite.pm b/PBot/MessageHistory_SQLite.pm index 9289e7c4..65f31ffa 100644 --- a/PBot/MessageHistory_SQLite.pm +++ b/PBot/MessageHistory_SQLite.pm @@ -8,6 +8,7 @@ # file, You can obtain one at http://mozilla.org/MPL/2.0/. package PBot::MessageHistory_SQLite; + use parent 'PBot::Class'; use warnings; use strict; @@ -21,57 +22,58 @@ use Text::Levenshtein qw/fastdistance/; use Time::Duration; sub initialize { - my ($self, %conf) = @_; - $self->{filename} = $conf{filename} // $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/message_history.sqlite3'; - $self->{new_entries} = 0; + my ($self, %conf) = @_; + $self->{filename} = $conf{filename} // $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/message_history.sqlite3'; + $self->{new_entries} = 0; - $self->{pbot}->{registry}->add_default('text', 'messagehistory', 'debug_link', 0); - $self->{pbot}->{registry}->add_default('text', 'messagehistory', 'debug_aka', 0); - $self->{pbot}->{registry}->add_default('text', 'messagehistory', 'sqlite_commit_interval', 30); - $self->{pbot}->{registry}->add_default('text', 'messagehistory', 'sqlite_debug', $conf{sqlite_debug} // 0); + $self->{pbot}->{registry}->add_default('text', 'messagehistory', 'debug_link', 0); + $self->{pbot}->{registry}->add_default('text', 'messagehistory', 'debug_aka', 0); + $self->{pbot}->{registry}->add_default('text', 'messagehistory', 'sqlite_commit_interval', 30); + $self->{pbot}->{registry}->add_default('text', 'messagehistory', 'sqlite_debug', $conf{sqlite_debug} // 0); - $self->{pbot}->{registry}->add_trigger('messagehistory', 'sqlite_commit_interval', sub { $self->sqlite_commit_interval_trigger(@_) }); - $self->{pbot}->{registry}->add_trigger('messagehistory', 'sqlite_debug', sub { $self->sqlite_debug_trigger(@_) }); + $self->{pbot}->{registry}->add_trigger('messagehistory', 'sqlite_commit_interval', sub { $self->sqlite_commit_interval_trigger(@_) }); + $self->{pbot}->{registry}->add_trigger('messagehistory', 'sqlite_debug', sub { $self->sqlite_debug_trigger(@_) }); - $self->{pbot}->{timer}->register( - sub { $self->commit_message_history }, - $self->{pbot}->{registry}->get_value('messagehistory', 'sqlite_commit_interval'), - 'messagehistory_sqlite_commit_interval' - ); + $self->{pbot}->{timer}->register( + sub { $self->commit_message_history }, + $self->{pbot}->{registry}->get_value('messagehistory', 'sqlite_commit_interval'), + 'messagehistory_sqlite_commit_interval' + ); - $self->{alias_type}->{WEAK} = 0; - $self->{alias_type}->{STRONG} = 1; + $self->{alias_type}->{WEAK} = 0; + $self->{alias_type}->{STRONG} = 1; } sub sqlite_commit_interval_trigger { - my ($self, $section, $item, $newvalue) = @_; - $self->{pbot}->{timer}->update_interval('messagehistory_sqlite_commit_interval', $newvalue); + my ($self, $section, $item, $newvalue) = @_; + $self->{pbot}->{timer}->update_interval('messagehistory_sqlite_commit_interval', $newvalue); } sub sqlite_debug_trigger { - my ($self, $section, $item, $newvalue) = @_; - $self->{dbh}->trace($self->{dbh}->parse_trace_flags("SQL|$newvalue")) if defined $self->{dbh}; + my ($self, $section, $item, $newvalue) = @_; + $self->{dbh}->trace($self->{dbh}->parse_trace_flags("SQL|$newvalue")) if defined $self->{dbh}; } sub begin { - my $self = shift; + my $self = shift; - $self->{pbot}->{logger}->log("Opening message history SQLite database: $self->{filename}\n"); + $self->{pbot}->{logger}->log("Opening message history SQLite database: $self->{filename}\n"); - $self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", { RaiseError => 1, PrintError => 0, AutoInactiveDestroy => 1, sqlite_unicode => 1 }) or die $DBI::errstr; + $self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", {RaiseError => 1, PrintError => 0, AutoInactiveDestroy => 1, sqlite_unicode => 1}) + or die $DBI::errstr; - $self->{dbh}->sqlite_enable_load_extension(my $_enabled = 1); - $self->{dbh}->prepare("SELECT load_extension('/usr/lib/sqlite3/pcre.so')"); + $self->{dbh}->sqlite_enable_load_extension(my $_enabled = 1); + $self->{dbh}->prepare("SELECT load_extension('/usr/lib/sqlite3/pcre.so')"); - eval { - my $sqlite_debug = $self->{pbot}->{registry}->get_value('messagehistory', 'sqlite_debug'); - use PBot::SQLiteLoggerLayer; - use PBot::SQLiteLogger; - open $self->{trace_layer}, '>:via(PBot::SQLiteLoggerLayer)', PBot::SQLiteLogger->new(pbot => $self->{pbot}); - $self->{dbh}->trace($self->{dbh}->parse_trace_flags("SQL|$sqlite_debug"), $self->{trace_layer}); + eval { + my $sqlite_debug = $self->{pbot}->{registry}->get_value('messagehistory', 'sqlite_debug'); + use PBot::SQLiteLoggerLayer; + use PBot::SQLiteLogger; + open $self->{trace_layer}, '>:via(PBot::SQLiteLoggerLayer)', PBot::SQLiteLogger->new(pbot => $self->{pbot}); + $self->{dbh}->trace($self->{dbh}->parse_trace_flags("SQL|$sqlite_debug"), $self->{trace_layer}); - $self->{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do('CREATE INDEX IF NOT EXISTS MsgIdx1 ON Messages(id, channel, mode)'); - $self->{dbh}->do('CREATE INDEX IF NOT EXISTS AliasIdx1 ON Aliases(id, alias, type)'); - $self->{dbh}->do('CREATE INDEX IF NOT EXISTS AliasIdx2 ON Aliases(alias, id, type)'); + $self->{dbh}->do('CREATE INDEX IF NOT EXISTS MsgIdx1 ON Messages(id, channel, mode)'); + $self->{dbh}->do('CREATE INDEX IF NOT EXISTS AliasIdx1 ON Aliases(id, alias, type)'); + $self->{dbh}->do('CREATE INDEX IF NOT EXISTS AliasIdx2 ON Aliases(alias, id, type)'); - $self->{dbh}->do('CREATE INDEX IF NOT EXISTS hostmask_nick_idx on Hostmasks (nick)'); - $self->{dbh}->do('CREATE INDEX IF NOT EXISTS hostmask_host_idx on Hostmasks (host)'); - $self->{dbh}->do('CREATE INDEX IF NOT EXISTS hostmasks_id_idx on Hostmasks (id)'); - $self->{dbh}->do('CREATE INDEX IF NOT EXISTS gecos_id_idx on Gecos (id)'); - $self->{dbh}->do('CREATE INDEX IF NOT EXISTS nickserv_id_idx on Nickserv (id)'); + $self->{dbh}->do('CREATE INDEX IF NOT EXISTS hostmask_nick_idx on Hostmasks (nick)'); + $self->{dbh}->do('CREATE INDEX IF NOT EXISTS hostmask_host_idx on Hostmasks (host)'); + $self->{dbh}->do('CREATE INDEX IF NOT EXISTS hostmasks_id_idx on Hostmasks (id)'); + $self->{dbh}->do('CREATE INDEX IF NOT EXISTS gecos_id_idx on Gecos (id)'); + $self->{dbh}->do('CREATE INDEX IF NOT EXISTS nickserv_id_idx on Nickserv (id)'); - $self->{dbh}->begin_work(); - }; - $self->{pbot}->{logger}->log($@) if $@; + $self->{dbh}->begin_work(); + }; + $self->{pbot}->{logger}->log($@) if $@; } sub end { - my $self = shift; + my $self = shift; - $self->{pbot}->{logger}->log("Closing message history SQLite database\n"); + $self->{pbot}->{logger}->log("Closing message history SQLite database\n"); - if (exists $self->{dbh} and defined $self->{dbh}) { - $self->{dbh}->commit() if $self->{new_entries}; - $self->{dbh}->disconnect(); - delete $self->{dbh}; - } + if (exists $self->{dbh} and defined $self->{dbh}) { + $self->{dbh}->commit() if $self->{new_entries}; + $self->{dbh}->disconnect(); + delete $self->{dbh}; + } } sub get_gecos { - my ($self, $id) = @_; + my ($self, $id) = @_; - my $gecos = eval { - my $sth = $self->{dbh}->prepare('SELECT gecos FROM Gecos WHERE ID = ?'); - $sth->execute($id); - return $sth->fetchall_arrayref(); - }; - $self->{pbot}->{logger}->log($@) if $@; - return map {$_->[0]} @$gecos; + my $gecos = eval { + my $sth = $self->{dbh}->prepare('SELECT gecos FROM Gecos WHERE ID = ?'); + $sth->execute($id); + return $sth->fetchall_arrayref(); + }; + $self->{pbot}->{logger}->log($@) if $@; + return map { $_->[0] } @$gecos; } sub get_nickserv_accounts { - my ($self, $id) = @_; + my ($self, $id) = @_; - my $nickserv_accounts = eval { - my $sth = $self->{dbh}->prepare('SELECT nickserv FROM Nickserv WHERE ID = ?'); - $sth->execute($id); - return $sth->fetchall_arrayref(); - }; - $self->{pbot}->{logger}->log($@) if $@; - return map {$_->[0]} @$nickserv_accounts; + my $nickserv_accounts = eval { + my $sth = $self->{dbh}->prepare('SELECT nickserv FROM Nickserv WHERE ID = ?'); + $sth->execute($id); + return $sth->fetchall_arrayref(); + }; + $self->{pbot}->{logger}->log($@) if $@; + return map { $_->[0] } @$nickserv_accounts; } sub set_current_nickserv_account { - my ($self, $id, $nickserv) = @_; + my ($self, $id, $nickserv) = @_; - eval { - my $sth = $self->{dbh}->prepare('UPDATE Accounts SET nickserv = ? WHERE id = ?'); - $sth->execute($nickserv, $id); - $self->{new_entries}++; - }; - $self->{pbot}->{logger}->log($@) if $@; + eval { + my $sth = $self->{dbh}->prepare('UPDATE Accounts SET nickserv = ? WHERE id = ?'); + $sth->execute($nickserv, $id); + $self->{new_entries}++; + }; + $self->{pbot}->{logger}->log($@) if $@; } sub get_current_nickserv_account { - my ($self, $id) = @_; + my ($self, $id) = @_; - my $nickserv = eval { - my $sth = $self->{dbh}->prepare('SELECT nickserv FROM Accounts WHERE id = ?'); - $sth->execute($id); - my $row = $sth->fetchrow_hashref(); - if (defined $row) { - return $row->{'nickserv'}; - } else { - return undef; - } - }; - $self->{pbot}->{logger}->log($@) if $@; - return $nickserv; + my $nickserv = eval { + my $sth = $self->{dbh}->prepare('SELECT nickserv FROM Accounts WHERE id = ?'); + $sth->execute($id); + my $row = $sth->fetchrow_hashref(); + if (defined $row) { return $row->{'nickserv'}; } + else { return undef; } + }; + $self->{pbot}->{logger}->log($@) if $@; + return $nickserv; } sub create_nickserv { - my ($self, $id, $nickserv) = @_; + my ($self, $id, $nickserv) = @_; - eval { - my $sth = $self->{dbh}->prepare('INSERT OR IGNORE INTO Nickserv VALUES (?, ?, 0)'); - my $rv = $sth->execute($id, $nickserv); - $self->{new_entries}++; - }; - $self->{pbot}->{logger}->log($@) if $@; + eval { + my $sth = $self->{dbh}->prepare('INSERT OR IGNORE INTO Nickserv VALUES (?, ?, 0)'); + my $rv = $sth->execute($id, $nickserv); + $self->{new_entries}++; + }; + $self->{pbot}->{logger}->log($@) if $@; } sub update_nickserv_account { - my ($self, $id, $nickserv, $timestamp) = @_; + my ($self, $id, $nickserv, $timestamp) = @_; - #$self->{pbot}->{logger}->log("Updating nickserv account for id $id to $nickserv with timestamp [$timestamp]\n"); + #$self->{pbot}->{logger}->log("Updating nickserv account for id $id to $nickserv with timestamp [$timestamp]\n"); - $self->create_nickserv($id, $nickserv); + $self->create_nickserv($id, $nickserv); - eval { - my $sth = $self->{dbh}->prepare('UPDATE Nickserv SET timestamp = ? WHERE id = ? AND nickserv = ?'); - $sth->execute($timestamp, $id, $nickserv); - $self->{new_entries}++; - }; - $self->{pbot}->{logger}->log($@) if $@; + eval { + my $sth = $self->{dbh}->prepare('UPDATE Nickserv SET timestamp = ? WHERE id = ? AND nickserv = ?'); + $sth->execute($timestamp, $id, $nickserv); + $self->{new_entries}++; + }; + $self->{pbot}->{logger}->log($@) if $@; } sub create_gecos { - my ($self, $id, $gecos) = @_; + my ($self, $id, $gecos) = @_; - eval { - my $sth = $self->{dbh}->prepare('INSERT OR IGNORE INTO Gecos VALUES (?, ?, 0)'); - my $rv = $sth->execute($id, $gecos); - $self->{new_entries}++ if $sth->rows; - }; - $self->{pbot}->{logger}->log($@) if $@; + eval { + my $sth = $self->{dbh}->prepare('INSERT OR IGNORE INTO Gecos VALUES (?, ?, 0)'); + my $rv = $sth->execute($id, $gecos); + $self->{new_entries}++ if $sth->rows; + }; + $self->{pbot}->{logger}->log($@) if $@; } sub update_gecos { - my ($self, $id, $gecos, $timestamp) = @_; + my ($self, $id, $gecos, $timestamp) = @_; - $self->create_gecos($id, $gecos); + $self->create_gecos($id, $gecos); - eval { - my $sth = $self->{dbh}->prepare('UPDATE Gecos SET timestamp = ? WHERE id = ? AND gecos = ?'); - $sth->execute($timestamp, $id, $gecos); - $self->{new_entries}++; - }; - $self->{pbot}->{logger}->log($@) if $@; + eval { + my $sth = $self->{dbh}->prepare('UPDATE Gecos SET timestamp = ? WHERE id = ? AND gecos = ?'); + $sth->execute($timestamp, $id, $gecos); + $self->{new_entries}++; + }; + $self->{pbot}->{logger}->log($@) if $@; } sub add_message_account { - my ($self, $mask, $link_id, $link_type) = @_; - my $id; - my ($nick, $user, $host) = $mask =~ m/^([^!]+)!([^@]+)@(.*)/; + my ($self, $mask, $link_id, $link_type) = @_; + my $id; + my ($nick, $user, $host) = $mask =~ m/^([^!]+)!([^@]+)@(.*)/; - if (defined $link_id and $link_type == $self->{alias_type}->{STRONG}) { - $id = $link_id; - } else { - $id = $self->get_new_account_id(); - $self->{pbot}->{logger}->log("Got new account id $id\n"); - } - - eval { - my $sth = $self->{dbh}->prepare('INSERT INTO Hostmasks VALUES (?, ?, ?, 0, ?, ?, ?)'); - $sth->execute($mask, $id, scalar gettimeofday, $nick, $user, $host); - $self->{new_entries}++; - - if ((not defined $link_id) || ((defined $link_id) && ($link_type == $self->{alias_type}->{WEAK}))) { - $sth = $self->{dbh}->prepare('INSERT INTO Accounts VALUES (?, ?, ?)'); - $sth->execute($id, $mask, ""); - $self->{new_entries}++; - - $self->{pbot}->{logger}->log("Added new account $id for mask $mask\n"); + if (defined $link_id and $link_type == $self->{alias_type}->{STRONG}) { $id = $link_id; } + else { + $id = $self->get_new_account_id(); + $self->{pbot}->{logger}->log("Got new account id $id\n"); } - }; - $self->{pbot}->{logger}->log($@) if $@; + eval { + my $sth = $self->{dbh}->prepare('INSERT INTO Hostmasks VALUES (?, ?, ?, 0, ?, ?, ?)'); + $sth->execute($mask, $id, scalar gettimeofday, $nick, $user, $host); + $self->{new_entries}++; - if (defined $link_id && $link_type == $self->{alias_type}->{WEAK}) { - $self->{pbot}->{logger}->log("Weakly linking $id to $link_id\n"); - $self->link_alias($id, $link_id, $link_type); - } + if ((not defined $link_id) || ((defined $link_id) && ($link_type == $self->{alias_type}->{WEAK}))) { + $sth = $self->{dbh}->prepare('INSERT INTO Accounts VALUES (?, ?, ?)'); + $sth->execute($id, $mask, ""); + $self->{new_entries}++; - return $id; + $self->{pbot}->{logger}->log("Added new account $id for mask $mask\n"); + } + }; + + $self->{pbot}->{logger}->log($@) if $@; + + if (defined $link_id && $link_type == $self->{alias_type}->{WEAK}) { + $self->{pbot}->{logger}->log("Weakly linking $id to $link_id\n"); + $self->link_alias($id, $link_id, $link_type); + } + + return $id; } sub find_message_account_by_id { - my ($self, $id) = @_; + my ($self, $id) = @_; - my $hostmask = eval { - my $sth = $self->{dbh}->prepare('SELECT hostmask FROM Hostmasks WHERE id = ? ORDER BY last_seen DESC LIMIT 1'); - $sth->execute($id); - my $row = $sth->fetchrow_hashref(); - return $row->{hostmask}; - }; + my $hostmask = eval { + my $sth = $self->{dbh}->prepare('SELECT hostmask FROM Hostmasks WHERE id = ? ORDER BY last_seen DESC LIMIT 1'); + $sth->execute($id); + my $row = $sth->fetchrow_hashref(); + return $row->{hostmask}; + }; - $self->{pbot}->{logger}->log($@) if $@; - return $hostmask; + $self->{pbot}->{logger}->log($@) if $@; + return $hostmask; } sub find_message_account_by_nick { - my ($self, $nick) = @_; + my ($self, $nick) = @_; - my ($id, $hostmask) = eval { - my $sth = $self->{dbh}->prepare('SELECT id, hostmask FROM Hostmasks WHERE nick = ? ORDER BY last_seen DESC LIMIT 1'); - $sth->execute($nick); - my $row = $sth->fetchrow_hashref(); - return ($row->{id}, $row->{hostmask}); - }; + my ($id, $hostmask) = eval { + my $sth = $self->{dbh}->prepare('SELECT id, hostmask FROM Hostmasks WHERE nick = ? ORDER BY last_seen DESC LIMIT 1'); + $sth->execute($nick); + my $row = $sth->fetchrow_hashref(); + return ($row->{id}, $row->{hostmask}); + }; - $self->{pbot}->{logger}->log($@) if $@; - return ($id, $hostmask); + $self->{pbot}->{logger}->log($@) if $@; + return ($id, $hostmask); } sub find_message_accounts_by_nickserv { - my ($self, $nickserv) = @_; + my ($self, $nickserv) = @_; - my $accounts = eval { - my $sth = $self->{dbh}->prepare('SELECT id FROM Nickserv WHERE nickserv = ?'); - $sth->execute($nickserv); - return $sth->fetchall_arrayref(); - }; - $self->{pbot}->{logger}->log($@) if $@; - return map {$_->[0]} @$accounts; + my $accounts = eval { + my $sth = $self->{dbh}->prepare('SELECT id FROM Nickserv WHERE nickserv = ?'); + $sth->execute($nickserv); + return $sth->fetchall_arrayref(); + }; + $self->{pbot}->{logger}->log($@) if $@; + return map { $_->[0] } @$accounts; } sub find_message_accounts_by_mask { - my ($self, $mask) = @_; + my ($self, $mask) = @_; - my $qmask = quotemeta $mask; - $qmask =~ s/_/\\_/g; - $qmask =~ s/\\\*/%/g; - $qmask =~ s/\\\?/_/g; - $qmask =~ s/\\\$.*$//; + my $qmask = quotemeta $mask; + $qmask =~ s/_/\\_/g; + $qmask =~ s/\\\*/%/g; + $qmask =~ s/\\\?/_/g; + $qmask =~ s/\\\$.*$//; - my $accounts = eval { - my $sth = $self->{dbh}->prepare('SELECT id FROM Hostmasks WHERE hostmask LIKE ? ESCAPE "\"'); - $sth->execute($qmask); - return $sth->fetchall_arrayref(); - }; - $self->{pbot}->{logger}->log($@) if $@; - return map {$_->[0]} @$accounts; + my $accounts = eval { + my $sth = $self->{dbh}->prepare('SELECT id FROM Hostmasks WHERE hostmask LIKE ? ESCAPE "\"'); + $sth->execute($qmask); + return $sth->fetchall_arrayref(); + }; + $self->{pbot}->{logger}->log($@) if $@; + return map { $_->[0] } @$accounts; } sub get_message_account_ancestor { - my $self = shift; - my $id = $self->get_message_account(@_); - $id = $self->get_ancestor_id($id); - return $id; + my $self = shift; + my $id = $self->get_message_account(@_); + $id = $self->get_ancestor_id($id); + return $id; } sub get_message_account { - my ($self, $nick, $user, $host, $orig_nick) = @_; + my ($self, $nick, $user, $host, $orig_nick) = @_; - ($nick, $user, $host) = $self->{pbot}->{irchandlers}->normalize_hostmask($nick, $user, $host); + ($nick, $user, $host) = $self->{pbot}->{irchandlers}->normalize_hostmask($nick, $user, $host); =cut use Devel::StackTrace; @@ -384,1436 +382,1432 @@ sub get_message_account { $self->{pbot}->{logger}->log("get_message_account stacktrace: " . $trace->as_string() . "\n"); =cut - my $mask = "$nick!$user\@$host"; - my $id = $self->get_message_account_id($mask); - return $id if defined $id; + my $mask = "$nick!$user\@$host"; + my $id = $self->get_message_account_id($mask); + return $id if defined $id; - $self->{pbot}->{logger}->log("Getting new message account for $nick!$user\@$host...\n"); - $self->{pbot}->{logger}->log("It's a nick-change!\n") if defined $orig_nick; + $self->{pbot}->{logger}->log("Getting new message account for $nick!$user\@$host...\n"); + $self->{pbot}->{logger}->log("It's a nick-change!\n") if defined $orig_nick; - my $do_nothing = 0; - my $sth; + my $do_nothing = 0; + my $sth; - my ($rows, $link_type) = eval { - my ($account1) = $host =~ m{/([^/]+)$}; - $account1 = '' if not defined $account1; + my ($rows, $link_type) = eval { + my ($account1) = $host =~ m{/([^/]+)$}; + $account1 = '' if not defined $account1; - my $hostip = undef; - if ($host =~ m/(\d+[[:punct:]]\d+[[:punct:]]\d+[[:punct:]]\d+)\D/) { - $hostip = $1; - $hostip =~ s/[[:punct:]]/./g; - } - - if (defined $orig_nick) { - my $orig_id = $self->get_message_account_id("$orig_nick!$user\@$host"); - my @orig_nickserv_accounts = $self->get_nickserv_accounts($orig_id); - - if ($nick =~ m/^Guest\d+$/) { - $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE user = ? and host = ? ORDER BY last_seen DESC'); - $sth->execute($user, $host); - my $rows = $sth->fetchall_arrayref({}); - if (defined $rows->[0]) { - my $link_type = $self->{alias_type}->{STRONG}; - if (gettimeofday - $rows->[0]->{last_seen} > 60 * 60 * 48) { - $link_type = $self->{alias_type}->{WEAK}; - $self->{pbot}->{logger}->log("Longer than 48 hours (" . concise duration(gettimeofday - $rows->[0]->{last_seen}) . ") for $rows->[0]->{hostmask} for $nick!$user\@$host, degrading to weak link\n"); - } - $self->{pbot}->{logger}->log("6: nick-change guest match: $rows->[0]->{id}: $rows->[0]->{hostmask}\n"); - $orig_nick = undef; - return ($rows, $link_type); + my $hostip = undef; + if ($host =~ m/(\d+[[:punct:]]\d+[[:punct:]]\d+[[:punct:]]\d+)\D/) { + $hostip = $1; + $hostip =~ s/[[:punct:]]/./g; } - } - $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE nick = ? ORDER BY last_seen DESC'); - $sth->execute($nick); - my $rows = $sth->fetchall_arrayref({}); + if (defined $orig_nick) { + my $orig_id = $self->get_message_account_id("$orig_nick!$user\@$host"); + my @orig_nickserv_accounts = $self->get_nickserv_accounts($orig_id); - if (not defined $rows->[0]) { - $rows->[0] = { id => $orig_id, hostmask => "$orig_nick!$user\@$host" }; - return ($rows, $self->{alias_type}->{STRONG}); - } - - my %processed_nicks; - my %processed_akas; - foreach my $row (@$rows) { - $self->{pbot}->{logger}->log("Found matching nickchange account: [$row->{id}] $row->{hostmask}\n"); - my ($tnick) = $row->{hostmask} =~ m/^([^!]+)!/; - - next if exists $processed_nicks{lc $tnick}; - $processed_nicks{lc $tnick} = 1; - - my %akas = $self->get_also_known_as($tnick); - foreach my $aka (keys %akas) { - next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; - next if $akas{$aka}->{nickchange} == 1; - - next if exists $processed_akas{$akas{$aka}->{id}}; - $processed_akas{$akas{$aka}->{id}} = 1; - - $self->{pbot}->{logger}->log("Testing alias [$akas{$aka}->{id}] $aka\n"); - my $match = 0; - - if ($akas{$aka}->{id} == $orig_id || $aka =~ m/^.*!\Q$user\E\@\Q$host\E$/i) { - $self->{pbot}->{logger}->log("1: match: $akas{$aka}->{id} vs $orig_id // $aka vs *!$user\@$host\n"); - $match = 1; - goto MATCH; - } - - if (@orig_nickserv_accounts) { - my @nickserv_accounts = $self->get_nickserv_accounts($akas{$aka}->{id}); - foreach my $ns1 (@orig_nickserv_accounts) { - foreach my $ns2 (@nickserv_accounts) { - if ($ns1 eq $ns2) { - $self->{pbot}->{logger}->log("Got matching nickserv: $ns1\n"); - $match = 1; - goto MATCH; + if ($nick =~ m/^Guest\d+$/) { + $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE user = ? and host = ? ORDER BY last_seen DESC'); + $sth->execute($user, $host); + my $rows = $sth->fetchall_arrayref({}); + if (defined $rows->[0]) { + my $link_type = $self->{alias_type}->{STRONG}; + if (gettimeofday - $rows->[0]->{last_seen} > 60 * 60 * 48) { + $link_type = $self->{alias_type}->{WEAK}; + $self->{pbot}->{logger}->log( + "Longer than 48 hours (" . concise duration(gettimeofday - $rows->[0]->{last_seen}) . ") for $rows->[0]->{hostmask} for $nick!$user\@$host, degrading to weak link\n"); + } + $self->{pbot}->{logger}->log("6: nick-change guest match: $rows->[0]->{id}: $rows->[0]->{hostmask}\n"); + $orig_nick = undef; + return ($rows, $link_type); } - } } - } - my ($thost) = $aka =~ m/@(.*)$/; + $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE nick = ? ORDER BY last_seen DESC'); + $sth->execute($nick); + my $rows = $sth->fetchall_arrayref({}); - if ($thost =~ m{/}) { - my ($account2) = $thost =~ m{/([^/]+)$}; - - if ($account1 ne $account2) { - $self->{pbot}->{logger}->log("Skipping non-matching cloaked hosts: $host vs $thost\n"); - next; - } else { - $self->{pbot}->{logger}->log("Cloaked hosts match: $host vs $thost\n"); - $rows->[0] = { id => $self->get_ancestor_id($akas{$aka}->{id}), hostmask => $aka }; - return ($rows, $self->{alias_type}->{STRONG}); + if (not defined $rows->[0]) { + $rows->[0] = {id => $orig_id, hostmask => "$orig_nick!$user\@$host"}; + return ($rows, $self->{alias_type}->{STRONG}); } - } - my $distance = fastdistance($host, $thost); - my $length = (length($host) > length($thost)) ? length $host : length $thost; + my %processed_nicks; + my %processed_akas; + foreach my $row (@$rows) { + $self->{pbot}->{logger}->log("Found matching nickchange account: [$row->{id}] $row->{hostmask}\n"); + my ($tnick) = $row->{hostmask} =~ m/^([^!]+)!/; - #$self->{pbot}->{logger}->log("distance: " . ($distance / $length) . " -- $host vs $thost\n") if $length != 0; + next if exists $processed_nicks{lc $tnick}; + $processed_nicks{lc $tnick} = 1; - if ($length != 0 && $distance / $length < 0.50) { - $self->{pbot}->{logger}->log("2: distance match: $host vs $thost == " . ($distance / $length) . "\n"); - $match = 1; - } else { - # handle cases like 99.57.140.149 vs 99-57-140-149.lightspeed.sntcca.sbcglobal.net - if (defined $hostip) { - if ($hostip eq $thost) { - $match = 1; - $self->{pbot}->{logger}->log("3: IP vs hostname match: $host vs $thost\n"); - } - } elsif ($thost =~ m/(\d+[[:punct:]]\d+[[:punct:]]\d+[[:punct:]]\d+)\D/) { - my $thostip = $1; - $thostip =~ s/[[:punct:]]/./g; - if ($thostip eq $host) { - $match = 1; - $self->{pbot}->{logger}->log("4: IP vs hostname match: $host vs $thost\n"); - } + my %akas = $self->get_also_known_as($tnick); + foreach my $aka (keys %akas) { + next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; + next if $akas{$aka}->{nickchange} == 1; + + next if exists $processed_akas{$akas{$aka}->{id}}; + $processed_akas{$akas{$aka}->{id}} = 1; + + $self->{pbot}->{logger}->log("Testing alias [$akas{$aka}->{id}] $aka\n"); + my $match = 0; + + if ($akas{$aka}->{id} == $orig_id || $aka =~ m/^.*!\Q$user\E\@\Q$host\E$/i) { + $self->{pbot}->{logger}->log("1: match: $akas{$aka}->{id} vs $orig_id // $aka vs *!$user\@$host\n"); + $match = 1; + goto MATCH; + } + + if (@orig_nickserv_accounts) { + my @nickserv_accounts = $self->get_nickserv_accounts($akas{$aka}->{id}); + foreach my $ns1 (@orig_nickserv_accounts) { + foreach my $ns2 (@nickserv_accounts) { + if ($ns1 eq $ns2) { + $self->{pbot}->{logger}->log("Got matching nickserv: $ns1\n"); + $match = 1; + goto MATCH; + } + } + } + } + + my ($thost) = $aka =~ m/@(.*)$/; + + if ($thost =~ m{/}) { + my ($account2) = $thost =~ m{/([^/]+)$}; + + if ($account1 ne $account2) { + $self->{pbot}->{logger}->log("Skipping non-matching cloaked hosts: $host vs $thost\n"); + next; + } else { + $self->{pbot}->{logger}->log("Cloaked hosts match: $host vs $thost\n"); + $rows->[0] = {id => $self->get_ancestor_id($akas{$aka}->{id}), hostmask => $aka}; + return ($rows, $self->{alias_type}->{STRONG}); + } + } + + my $distance = fastdistance($host, $thost); + my $length = (length($host) > length($thost)) ? length $host : length $thost; + + #$self->{pbot}->{logger}->log("distance: " . ($distance / $length) . " -- $host vs $thost\n") if $length != 0; + + if ($length != 0 && $distance / $length < 0.50) { + $self->{pbot}->{logger}->log("2: distance match: $host vs $thost == " . ($distance / $length) . "\n"); + $match = 1; + } else { + + # handle cases like 99.57.140.149 vs 99-57-140-149.lightspeed.sntcca.sbcglobal.net + if (defined $hostip) { + if ($hostip eq $thost) { + $match = 1; + $self->{pbot}->{logger}->log("3: IP vs hostname match: $host vs $thost\n"); + } + } elsif ($thost =~ m/(\d+[[:punct:]]\d+[[:punct:]]\d+[[:punct:]]\d+)\D/) { + my $thostip = $1; + $thostip =~ s/[[:punct:]]/./g; + if ($thostip eq $host) { + $match = 1; + $self->{pbot}->{logger}->log("4: IP vs hostname match: $host vs $thost\n"); + } + } + } + + MATCH: + if ($match) { + $self->{pbot}->{logger}->log("Using this match.\n"); + $rows->[0] = {id => $self->get_ancestor_id($akas{$aka}->{id}), hostmask => $aka}; + return ($rows, $self->{alias_type}->{STRONG}); + } + } } - } - MATCH: - if ($match) { - $self->{pbot}->{logger}->log("Using this match.\n"); - $rows->[0] = { id => $self->get_ancestor_id($akas{$aka}->{id}), hostmask => $aka }; - return ($rows, $self->{alias_type}->{STRONG}); - } - } - } + $self->{pbot}->{logger}->log("Creating new nickchange account!\n"); - $self->{pbot}->{logger}->log("Creating new nickchange account!\n"); + my $new_id = $self->add_message_account($mask); + $self->link_alias($orig_id, $new_id, $self->{alias_type}->{WEAK}); + $self->update_hostmask_data($mask, {nickchange => 1, last_seen => scalar gettimeofday}); - my $new_id = $self->add_message_account($mask); - $self->link_alias($orig_id, $new_id, $self->{alias_type}->{WEAK}); - $self->update_hostmask_data($mask, { nickchange => 1, last_seen => scalar gettimeofday }); - - $do_nothing = 1; - $rows->[0] = { id => $new_id }; - return ($rows, 0); - } - - if ($host =~ m{^gateway/web/irccloud.com}) { - $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE host = ? ORDER BY last_seen DESC'); - $sth->execute("gateway/web/irccloud.com/x-$user"); - my $rows = $sth->fetchall_arrayref({}); - if (defined $rows->[0]) { - $self->{pbot}->{logger}->log("5: irccloud match: $rows->[0]->{id}: $rows->[0]->{hostmask}\n"); - return ($rows, $self->{alias_type}->{STRONG}); - } - } - - if ($host =~ m{^nat/([^/]+)/}) { - my $nat = $1; - $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE nick = ? AND host = ? ORDER BY last_seen DESC'); - $sth->execute($nick, "nat/$nat/x-$user"); - my $rows = $sth->fetchall_arrayref({}); - if (defined $rows->[0]) { - $self->{pbot}->{logger}->log("6: nat match: $rows->[0]->{id}: $rows->[0]->{hostmask}\n"); - return ($rows, $self->{alias_type}->{STRONG}); - } - } - - # cloaked hostmask - if ($host =~ m{/}) { - $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE host = ? ORDER BY last_seen DESC'); - $sth->execute($host); - my $rows = $sth->fetchall_arrayref({}); - if (defined $rows->[0]) { - $self->{pbot}->{logger}->log("6: cloak match: $rows->[0]->{id}: $rows->[0]->{hostmask}\n"); - return ($rows, $self->{alias_type}->{STRONG}); - } - } - - # guests - if ($nick =~ m/^Guest\d+$/) { - $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE user = ? and host = ? ORDER BY last_seen DESC'); - $sth->execute($user, $host); - my $rows = $sth->fetchall_arrayref({}); - if (defined $rows->[0]) { - my $link_type = $self->{alias_type}->{STRONG}; - if (gettimeofday - $rows->[0]->{last_seen} > 60 * 60 * 48) { - $link_type = $self->{alias_type}->{WEAK}; - $self->{pbot}->{logger}->log("Longer than 48 hours (" . concise duration(gettimeofday - $rows->[0]->{last_seen}) . ") for $rows->[0]->{hostmask} for $nick!$user\@$host, degrading to weak link\n"); - } - $self->{pbot}->{logger}->log("6: guest match: $rows->[0]->{id}: $rows->[0]->{hostmask}\n"); - return ($rows, $link_type); - } - } - - $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE nick = ? ORDER BY last_seen DESC'); - $sth->execute($nick); - my $rows = $sth->fetchall_arrayref({}); - - my $link_type = $self->{alias_type}->{WEAK}; - my %processed_nicks; - my %processed_akas; - - foreach my $row (@$rows) { - $self->{pbot}->{logger}->log("Found matching nick $row->{hostmask} with id $row->{id}\n"); - my ($tnick) = $row->{hostmask} =~ m/^([^!]+)!/; - - next if exists $processed_nicks{lc $tnick}; - $processed_nicks{lc $tnick} = 1; - - my %akas = $self->get_also_known_as($tnick); - foreach my $aka (keys %akas) { - next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; - next if $akas{$aka}->{nickchange} == 1; - - next if exists $processed_akas{$akas{$aka}->{id}}; - $processed_akas{$akas{$aka}->{id}} = 1; - - $self->{pbot}->{logger}->log("Testing alias [$akas{$aka}->{id}] $aka\n"); - - my ($thost) = $aka =~ m/@(.*)$/; - - if ($thost =~ m{/}) { - my ($account2) = $thost =~ m{/([^/]+)$}; - - if ($account1 ne $account2) { - $self->{pbot}->{logger}->log("Skipping non-matching cloaked hosts: $host vs $thost\n"); - next; - } else { - $self->{pbot}->{logger}->log("Cloaked hosts match: $host vs $thost\n"); - $rows->[0] = { id => $self->get_ancestor_id($akas{$aka}->{id}), hostmask => $aka }; - return ($rows, $self->{alias_type}->{STRONG}); - } + $do_nothing = 1; + $rows->[0] = {id => $new_id}; + return ($rows, 0); } - my $distance = fastdistance($host, $thost); - my $length = (length($host) > length($thost)) ? length $host : length $thost; - - #$self->{pbot}->{logger}->log("distance: " . ($distance / $length) . " -- $host vs $thost\n") if $length != 0; - - my $match = 0; - - if ($length != 0 && $distance / $length < 0.50) { - $self->{pbot}->{logger}->log("7: distance match: $host vs $thost == " . ($distance / $length) . "\n"); - $match = 1; - } else { - # handle cases like 99.57.140.149 vs 99-57-140-149.lightspeed.sntcca.sbcglobal.net - if (defined $hostip) { - if ($hostip eq $thost) { - $match = 1; - $self->{pbot}->{logger}->log("8: IP vs hostname match: $host vs $thost\n"); + if ($host =~ m{^gateway/web/irccloud.com}) { + $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE host = ? ORDER BY last_seen DESC'); + $sth->execute("gateway/web/irccloud.com/x-$user"); + my $rows = $sth->fetchall_arrayref({}); + if (defined $rows->[0]) { + $self->{pbot}->{logger}->log("5: irccloud match: $rows->[0]->{id}: $rows->[0]->{hostmask}\n"); + return ($rows, $self->{alias_type}->{STRONG}); } - } elsif ($thost =~ m/(\d+[[:punct:]]\d+[[:punct:]]\d+[[:punct:]]\d+)\D/) { - my $thostip = $1; - $thostip =~ s/[[:punct:]]/./g; - if ($thostip eq $host) { - $match = 1; - $self->{pbot}->{logger}->log("9: IP vs hostname match: $host vs $thost\n"); - } - } } - if ($match) { - $rows->[0] = { id => $self->get_ancestor_id($akas{$aka}->{id}), hostmask => $aka }; - return ($rows, $self->{alias_type}->{STRONG}); + if ($host =~ m{^nat/([^/]+)/}) { + my $nat = $1; + $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE nick = ? AND host = ? ORDER BY last_seen DESC'); + $sth->execute($nick, "nat/$nat/x-$user"); + my $rows = $sth->fetchall_arrayref({}); + if (defined $rows->[0]) { + $self->{pbot}->{logger}->log("6: nat match: $rows->[0]->{id}: $rows->[0]->{hostmask}\n"); + return ($rows, $self->{alias_type}->{STRONG}); + } } - } - } - if (not defined $rows->[0]) { - $link_type = $self->{alias_type}->{STRONG}; + # cloaked hostmask + if ($host =~ m{/}) { + $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE host = ? ORDER BY last_seen DESC'); + $sth->execute($host); + my $rows = $sth->fetchall_arrayref({}); + if (defined $rows->[0]) { + $self->{pbot}->{logger}->log("6: cloak match: $rows->[0]->{id}: $rows->[0]->{hostmask}\n"); + return ($rows, $self->{alias_type}->{STRONG}); + } + } - $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE user = ? AND host = ? ORDER BY last_seen DESC'); - $sth->execute($user, $host); - $rows = $sth->fetchall_arrayref({}); + # guests + if ($nick =~ m/^Guest\d+$/) { + $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE user = ? and host = ? ORDER BY last_seen DESC'); + $sth->execute($user, $host); + my $rows = $sth->fetchall_arrayref({}); + if (defined $rows->[0]) { + my $link_type = $self->{alias_type}->{STRONG}; + if (gettimeofday - $rows->[0]->{last_seen} > 60 * 60 * 48) { + $link_type = $self->{alias_type}->{WEAK}; + $self->{pbot}->{logger}->log( + "Longer than 48 hours (" . concise duration(gettimeofday - $rows->[0]->{last_seen}) . ") for $rows->[0]->{hostmask} for $nick!$user\@$host, degrading to weak link\n"); + } + $self->{pbot}->{logger}->log("6: guest match: $rows->[0]->{id}: $rows->[0]->{hostmask}\n"); + return ($rows, $link_type); + } + } - if (defined $rows->[0] and gettimeofday - $rows->[0]->{last_seen} > 60 * 60 * 48) { - $link_type = $self->{alias_type}->{WEAK}; - $self->{pbot}->{logger}->log("Longer than 48 hours (" . concise duration(gettimeofday - $rows->[0]->{last_seen}) . ") for $rows->[0]->{hostmask} for $nick!$user\@$host, degrading to weak link\n"); - } + $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE nick = ? ORDER BY last_seen DESC'); + $sth->execute($nick); + my $rows = $sth->fetchall_arrayref({}); + + my $link_type = $self->{alias_type}->{WEAK}; + my %processed_nicks; + my %processed_akas; + + foreach my $row (@$rows) { + $self->{pbot}->{logger}->log("Found matching nick $row->{hostmask} with id $row->{id}\n"); + my ($tnick) = $row->{hostmask} =~ m/^([^!]+)!/; + + next if exists $processed_nicks{lc $tnick}; + $processed_nicks{lc $tnick} = 1; + + my %akas = $self->get_also_known_as($tnick); + foreach my $aka (keys %akas) { + next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; + next if $akas{$aka}->{nickchange} == 1; + + next if exists $processed_akas{$akas{$aka}->{id}}; + $processed_akas{$akas{$aka}->{id}} = 1; + + $self->{pbot}->{logger}->log("Testing alias [$akas{$aka}->{id}] $aka\n"); + + my ($thost) = $aka =~ m/@(.*)$/; + + if ($thost =~ m{/}) { + my ($account2) = $thost =~ m{/([^/]+)$}; + + if ($account1 ne $account2) { + $self->{pbot}->{logger}->log("Skipping non-matching cloaked hosts: $host vs $thost\n"); + next; + } else { + $self->{pbot}->{logger}->log("Cloaked hosts match: $host vs $thost\n"); + $rows->[0] = {id => $self->get_ancestor_id($akas{$aka}->{id}), hostmask => $aka}; + return ($rows, $self->{alias_type}->{STRONG}); + } + } + + my $distance = fastdistance($host, $thost); + my $length = (length($host) > length($thost)) ? length $host : length $thost; + + #$self->{pbot}->{logger}->log("distance: " . ($distance / $length) . " -- $host vs $thost\n") if $length != 0; + + my $match = 0; + + if ($length != 0 && $distance / $length < 0.50) { + $self->{pbot}->{logger}->log("7: distance match: $host vs $thost == " . ($distance / $length) . "\n"); + $match = 1; + } else { + + # handle cases like 99.57.140.149 vs 99-57-140-149.lightspeed.sntcca.sbcglobal.net + if (defined $hostip) { + if ($hostip eq $thost) { + $match = 1; + $self->{pbot}->{logger}->log("8: IP vs hostname match: $host vs $thost\n"); + } + } elsif ($thost =~ m/(\d+[[:punct:]]\d+[[:punct:]]\d+[[:punct:]]\d+)\D/) { + my $thostip = $1; + $thostip =~ s/[[:punct:]]/./g; + if ($thostip eq $host) { + $match = 1; + $self->{pbot}->{logger}->log("9: IP vs hostname match: $host vs $thost\n"); + } + } + } + + if ($match) { + $rows->[0] = {id => $self->get_ancestor_id($akas{$aka}->{id}), hostmask => $aka}; + return ($rows, $self->{alias_type}->{STRONG}); + } + } + } + + if (not defined $rows->[0]) { + $link_type = $self->{alias_type}->{STRONG}; + + $sth = $self->{dbh}->prepare('SELECT id, hostmask, last_seen FROM Hostmasks WHERE user = ? AND host = ? ORDER BY last_seen DESC'); + $sth->execute($user, $host); + $rows = $sth->fetchall_arrayref({}); + + if (defined $rows->[0] and gettimeofday - $rows->[0]->{last_seen} > 60 * 60 * 48) { + $link_type = $self->{alias_type}->{WEAK}; + $self->{pbot}->{logger}->log( + "Longer than 48 hours (" . concise duration(gettimeofday - $rows->[0]->{last_seen}) . ") for $rows->[0]->{hostmask} for $nick!$user\@$host, degrading to weak link\n"); + } =cut foreach my $row (@$rows) { $self->{pbot}->{logger}->log("Found matching user\@host mask $row->{hostmask} with id $row->{id}\n"); } =cut - } - if (defined $rows->[0]) { - $self->{pbot}->{logger}->log("10: matching *!user\@host: $rows->[0]->{id}: $rows->[0]->{hostmask}\n"); + + } + if (defined $rows->[0]) { $self->{pbot}->{logger}->log("10: matching *!user\@host: $rows->[0]->{id}: $rows->[0]->{hostmask}\n"); } + + return ($rows, $link_type); + }; + $self->{pbot}->{logger}->log($@) if $@; + + return $rows->[0]->{id} if $do_nothing; + + if (defined $rows->[0] and not defined $orig_nick) { + if ($link_type == $self->{alias_type}->{STRONG}) { + + my $host1 = lc "$nick!$user\@$host"; + + my $host2 = lc $rows->[0]->{hostmask}; + my ($nick1) = $host1 =~ m/^([^!]+)!/; + my ($nick2) = $host2 =~ m/^([^!]+)!/; + my $distance = fastdistance($nick1, $nick2); + my $length = (length $nick1 > length $nick2) ? length $nick1 : length $nick2; + + if ($distance > 1 && ($nick1 !~ /^guest/ && $nick2 !~ /^guest/) && ($host1 !~ /unaffiliated/ || $host2 !~ /unaffiliated/)) { + my $id = $rows->[0]->{id}; + $self->{pbot}->{logger}->log("[$nick1][$nick2] $distance / $length\n"); + $self->{pbot}->{logger}->log("Possible bogus account: ($id) $host1 vs ($id) $host2\n"); + } + } + + $self->{pbot}->{logger}->log("message-history: [get-account] $nick!$user\@$host " + . ($link_type == $self->{alias_type}->{WEAK} ? "weakly linked to" : "added to account") + . " $rows->[0]->{hostmask} with id $rows->[0]->{id}\n"); + $self->add_message_account("$nick!$user\@$host", $rows->[0]->{id}, $link_type); + $self->devalidate_all_channels($rows->[0]->{id}); + $self->update_hostmask_data("$nick!$user\@$host", {last_seen => scalar gettimeofday}); + my @nickserv_accounts = $self->get_nickserv_accounts($rows->[0]->{id}); + foreach my $nickserv_account (@nickserv_accounts) { + $self->{pbot}->{logger}->log("$nick!$user\@$host [$rows->[0]->{id}] seen with nickserv account [$nickserv_account]\n"); + $self->{pbot}->{antiflood}->check_nickserv_accounts($nick, $nickserv_account, "$nick!$user\@$host"); + } + return $rows->[0]->{id}; } - return ($rows, $link_type); - }; - $self->{pbot}->{logger}->log($@) if $@; - - return $rows->[0]->{id} if $do_nothing; - - if (defined $rows->[0] and not defined $orig_nick) { - if ($link_type == $self->{alias_type}->{STRONG}) { - my $host1 = lc "$nick!$user\@$host"; - my $host2 = lc $rows->[0]->{hostmask}; - my ($nick1) = $host1 =~ m/^([^!]+)!/; - my ($nick2) = $host2 =~ m/^([^!]+)!/; - my $distance = fastdistance($nick1, $nick2); - my $length = (length $nick1 > length $nick2) ? length $nick1 : length $nick2; - if ($distance > 1 && ($nick1 !~ /^guest/ && $nick2 !~ /^guest/) && ($host1 !~ /unaffiliated/ || $host2 !~ /unaffiliated/)) { - my $id = $rows->[0]->{id}; - $self->{pbot}->{logger}->log("[$nick1][$nick2] $distance / $length\n"); - $self->{pbot}->{logger}->log("Possible bogus account: ($id) $host1 vs ($id) $host2\n"); - } - } - - $self->{pbot}->{logger}->log("message-history: [get-account] $nick!$user\@$host " . ($link_type == $self->{alias_type}->{WEAK} ? "weakly linked to" : "added to account") . " $rows->[0]->{hostmask} with id $rows->[0]->{id}\n"); - $self->add_message_account("$nick!$user\@$host", $rows->[0]->{id}, $link_type); - $self->devalidate_all_channels($rows->[0]->{id}); - $self->update_hostmask_data("$nick!$user\@$host", { last_seen => scalar gettimeofday }); - my @nickserv_accounts = $self->get_nickserv_accounts($rows->[0]->{id}); - foreach my $nickserv_account (@nickserv_accounts) { - $self->{pbot}->{logger}->log("$nick!$user\@$host [$rows->[0]->{id}] seen with nickserv account [$nickserv_account]\n"); - $self->{pbot}->{antiflood}->check_nickserv_accounts($nick, $nickserv_account, "$nick!$user\@$host"); - } - return $rows->[0]->{id}; - } - - $self->{pbot}->{logger}->log("No account found for mask [$mask], adding new account\n"); - return $self->add_message_account($mask); + $self->{pbot}->{logger}->log("No account found for mask [$mask], adding new account\n"); + return $self->add_message_account($mask); } sub find_most_recent_hostmask { - my ($self, $id) = @_; + my ($self, $id) = @_; - my $hostmask = eval { - my $sth = $self->{dbh}->prepare('SELECT hostmask FROM Hostmasks WHERE ID = ? ORDER BY last_seen DESC LIMIT 1'); - $sth->execute($id); - return $sth->fetchrow_hashref()->{'hostmask'}; - }; - $self->{pbot}->{logger}->log($@) if $@; - return $hostmask; + my $hostmask = eval { + my $sth = $self->{dbh}->prepare('SELECT hostmask FROM Hostmasks WHERE ID = ? ORDER BY last_seen DESC LIMIT 1'); + $sth->execute($id); + return $sth->fetchrow_hashref()->{'hostmask'}; + }; + $self->{pbot}->{logger}->log($@) if $@; + return $hostmask; } sub update_hostmask_data { - my ($self, $mask, $data) = @_; + my ($self, $mask, $data) = @_; - eval { - my $sql = 'UPDATE Hostmasks SET '; + eval { + my $sql = 'UPDATE Hostmasks 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 hostmask == ?'; + $sql .= ' WHERE hostmask == ?'; - 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, $mask); - $sth->execute(); - $self->{new_entries}++; - }; - $self->{pbot}->{logger}->log($@) if $@; + $sth->bind_param($param, $mask); + $sth->execute(); + $self->{new_entries}++; + }; + $self->{pbot}->{logger}->log($@) if $@; } sub get_nickserv_accounts_for_hostmask { - my ($self, $hostmask) = @_; + my ($self, $hostmask) = @_; - my $nickservs = eval { - my $sth = $self->{dbh}->prepare('SELECT nickserv FROM Hostmasks, Nickserv WHERE nickserv.id = hostmasks.id AND hostmasks.hostmask = ?'); - $sth->execute($hostmask); - return $sth->fetchall_arrayref(); - }; + my $nickservs = eval { + my $sth = $self->{dbh}->prepare('SELECT nickserv FROM Hostmasks, Nickserv WHERE nickserv.id = hostmasks.id AND hostmasks.hostmask = ?'); + $sth->execute($hostmask); + return $sth->fetchall_arrayref(); + }; - $self->{pbot}->{logger}->log($@) if $@; - return map {$_->[0]} @$nickservs; + $self->{pbot}->{logger}->log($@) if $@; + return map { $_->[0] } @$nickservs; } sub get_gecos_for_hostmask { - my ($self, $hostmask) = @_; + my ($self, $hostmask) = @_; - my $gecos = eval { - my $sth = $self->{dbh}->prepare('SELECT gecos FROM Hostmasks, Gecos WHERE gecos.id = hostmasks.id AND hostmasks.hostmask = ?'); - $sth->execute($hostmask); - return $sth->fetchall_arrayref(); - }; + my $gecos = eval { + my $sth = $self->{dbh}->prepare('SELECT gecos FROM Hostmasks, Gecos WHERE gecos.id = hostmasks.id AND hostmasks.hostmask = ?'); + $sth->execute($hostmask); + return $sth->fetchall_arrayref(); + }; - $self->{pbot}->{logger}->log($@) if $@; - return map {$_->[0]} @$gecos; + $self->{pbot}->{logger}->log($@) if $@; + return map { $_->[0] } @$gecos; } sub get_hostmasks_for_channel { - my ($self, $channel) = @_; + my ($self, $channel) = @_; - my $hostmasks = eval { - my $sth = $self->{dbh}->prepare('SELECT hostmasks.id, hostmask FROM Hostmasks, Channels WHERE channels.id = hostmasks.id AND channel = ?'); - $sth->execute($channel); - return $sth->fetchall_arrayref({}); - }; + my $hostmasks = eval { + my $sth = $self->{dbh}->prepare('SELECT hostmasks.id, hostmask FROM Hostmasks, Channels WHERE channels.id = hostmasks.id AND channel = ?'); + $sth->execute($channel); + return $sth->fetchall_arrayref({}); + }; - $self->{pbot}->{logger}->log($@) if $@; - return $hostmasks; + $self->{pbot}->{logger}->log($@) if $@; + return $hostmasks; } sub get_hostmasks_for_nickserv { - my ($self, $nickserv) = @_; + my ($self, $nickserv) = @_; - my $hostmasks = eval { - my $sth = $self->{dbh}->prepare('SELECT hostmasks.id, hostmask, nickserv FROM Hostmasks, Nickserv WHERE nickserv.id = hostmasks.id AND nickserv = ?'); - $sth->execute($nickserv); - return $sth->fetchall_arrayref({}); - }; + my $hostmasks = eval { + my $sth = $self->{dbh}->prepare('SELECT hostmasks.id, hostmask, nickserv FROM Hostmasks, Nickserv WHERE nickserv.id = hostmasks.id AND nickserv = ?'); + $sth->execute($nickserv); + return $sth->fetchall_arrayref({}); + }; - $self->{pbot}->{logger}->log($@) if $@; - return $hostmasks; + $self->{pbot}->{logger}->log($@) if $@; + return $hostmasks; } sub add_message { - my ($self, $id, $mask, $channel, $message) = @_; + my ($self, $id, $mask, $channel, $message) = @_; - #$self->{pbot}->{logger}->log("Adding message [$id][$mask][$channel][$message->{msg}][$message->{timestamp}][$message->{mode}]\n"); + #$self->{pbot}->{logger}->log("Adding message [$id][$mask][$channel][$message->{msg}][$message->{timestamp}][$message->{mode}]\n"); - eval { - my $sth = $self->{dbh}->prepare('INSERT INTO Messages VALUES (?, ?, ?, ?, ?)'); - $sth->execute($id, $channel, $message->{msg}, $message->{timestamp}, $message->{mode}); - $self->{new_entries}++; - }; - $self->{pbot}->{logger}->log($@) if $@; - $self->update_channel_data($id, $channel, { last_seen => $message->{timestamp} }); - $self->update_hostmask_data($mask, { last_seen => $message->{timestamp} }); + eval { + my $sth = $self->{dbh}->prepare('INSERT INTO Messages VALUES (?, ?, ?, ?, ?)'); + $sth->execute($id, $channel, $message->{msg}, $message->{timestamp}, $message->{mode}); + $self->{new_entries}++; + }; + $self->{pbot}->{logger}->log($@) if $@; + $self->update_channel_data($id, $channel, {last_seen => $message->{timestamp}}); + $self->update_hostmask_data($mask, {last_seen => $message->{timestamp}}); } sub get_recent_messages { - my ($self, $id, $channel, $limit, $mode, $nick) = @_; - $limit = 25 if not defined $limit; + my ($self, $id, $channel, $limit, $mode, $nick) = @_; + $limit = 25 if not defined $limit; - $channel = lc $channel; + $channel = lc $channel; - my $mode_query = ''; - $mode_query = "AND mode = $mode" if defined $mode; + my $mode_query = ''; + $mode_query = "AND mode = $mode" if defined $mode; - my $messages = eval { - my $sql = "SELECT msg, mode, timestamp FROM Messages WHERE "; + my $messages = eval { + my $sql = "SELECT msg, mode, timestamp FROM Messages WHERE "; - my %akas; - if (defined $mode and $mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { - %akas = $self->get_also_known_as($nick); - } else { - $akas{'this'} = { id => $id, type => $self->{alias_type}->{STRONG}, nickchange => 0 }; - } + my %akas; + if (defined $mode and $mode == $self->{pbot}->{messagehistory}->{MSG_NICKCHANGE}) { %akas = $self->get_also_known_as($nick); } + else { $akas{'this'} = {id => $id, type => $self->{alias_type}->{STRONG}, nickchange => 0}; } - my $ids; - my %seen_id; - my $or = ''; - foreach my $aka (keys %akas) { - next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; - next if $akas{$aka}->{nickchange} == 1; - next if exists $seen_id{$akas{$aka}->{id}}; - $seen_id{$akas{$aka}->{id}} = 1; + my $ids; + my %seen_id; + my $or = ''; + foreach my $aka (keys %akas) { + next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; + next if $akas{$aka}->{nickchange} == 1; + next if exists $seen_id{$akas{$aka}->{id}}; + $seen_id{$akas{$aka}->{id}} = 1; - $ids .= "${or}id = ?"; - $or = ' OR '; - } + $ids .= "${or}id = ?"; + $or = ' OR '; + } - $sql .= "($ids) AND channel = ? $mode_query ORDER BY timestamp ASC LIMIT ? OFFSET (SELECT COUNT(*) FROM Messages WHERE ($ids) AND channel = ? $mode_query) - ?"; - my $sth = $self->{dbh}->prepare($sql); + $sql .= "($ids) AND channel = ? $mode_query ORDER BY timestamp ASC LIMIT ? OFFSET (SELECT COUNT(*) FROM Messages WHERE ($ids) AND channel = ? $mode_query) - ?"; + my $sth = $self->{dbh}->prepare($sql); - my $param = 1; - %seen_id = (); - foreach my $aka (keys %akas) { - next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; - next if $akas{$aka}->{nickchange} == 1; - next if exists $seen_id{$akas{$aka}->{id}}; - $seen_id{$akas{$aka}->{id}} = 1; + my $param = 1; + %seen_id = (); + foreach my $aka (keys %akas) { + next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; + next if $akas{$aka}->{nickchange} == 1; + next if exists $seen_id{$akas{$aka}->{id}}; + $seen_id{$akas{$aka}->{id}} = 1; - $sth->bind_param($param++, $akas{$aka}->{id}); - } + $sth->bind_param($param++, $akas{$aka}->{id}); + } - $sth->bind_param($param++, $channel); - $sth->bind_param($param++, $limit); + $sth->bind_param($param++, $channel); + $sth->bind_param($param++, $limit); - %seen_id = (); - foreach my $aka (keys %akas) { - next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; - next if $akas{$aka}->{nickchange} == 1; - next if exists $seen_id{$akas{$aka}->{id}}; - $seen_id{$akas{$aka}->{id}} = 1; + %seen_id = (); + foreach my $aka (keys %akas) { + next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; + next if $akas{$aka}->{nickchange} == 1; + next if exists $seen_id{$akas{$aka}->{id}}; + $seen_id{$akas{$aka}->{id}} = 1; - $sth->bind_param($param++, $akas{$aka}->{id}); - } + $sth->bind_param($param++, $akas{$aka}->{id}); + } - $sth->bind_param($param++, $channel); - $sth->bind_param($param, $limit); - $sth->execute(); - return $sth->fetchall_arrayref({}); - }; - $self->{pbot}->{logger}->log($@) if $@; - return $messages; + $sth->bind_param($param++, $channel); + $sth->bind_param($param, $limit); + $sth->execute(); + return $sth->fetchall_arrayref({}); + }; + $self->{pbot}->{logger}->log($@) if $@; + return $messages; } sub get_recent_messages_from_channel { - my ($self, $channel, $limit, $mode, $direction) = @_; - $limit = 25 if not defined $limit; - $direction = 'ASC' if not defined $direction; + my ($self, $channel, $limit, $mode, $direction) = @_; + $limit = 25 if not defined $limit; + $direction = 'ASC' if not defined $direction; - $channel = lc $channel; + $channel = lc $channel; - my $mode_query = ''; - $mode_query = "AND mode = $mode" if defined $mode; + my $mode_query = ''; + $mode_query = "AND mode = $mode" if defined $mode; - my $messages = eval { - my $sql = "SELECT id, msg, mode, timestamp FROM Messages WHERE channel = ? $mode_query ORDER BY timestamp $direction LIMIT ?"; - my $sth = $self->{dbh}->prepare($sql); - $sth->execute($channel, $limit); - return $sth->fetchall_arrayref({}); - }; - $self->{pbot}->{logger}->log($@) if $@; - return $messages; + my $messages = eval { + my $sql = "SELECT id, msg, mode, timestamp FROM Messages WHERE channel = ? $mode_query ORDER BY timestamp $direction LIMIT ?"; + my $sth = $self->{dbh}->prepare($sql); + $sth->execute($channel, $limit); + return $sth->fetchall_arrayref({}); + }; + $self->{pbot}->{logger}->log($@) if $@; + return $messages; } sub get_message_context { - my ($self, $message, $before, $after, $count, $text, $context_id) = @_; + my ($self, $message, $before, $after, $count, $text, $context_id) = @_; - my ($messages_before, $messages_after, $messages_count); + my ($messages_before, $messages_after, $messages_count); + + if (defined $count and $count > 1) { + my $regex = '(?i)'; + $regex .= ($text =~ m/^\w/) ? '\b' : '\B'; + $regex .= quotemeta $text; + $regex .= ($text =~ m/\w$/) ? '\b' : '\B'; + $regex =~ s/\\\*/.*?/g; + + $messages_count = eval { + my $sth; + if (defined $context_id) { + $sth = $self->{dbh}->prepare( + 'SELECT id, msg, mode, timestamp, channel FROM Messages WHERE id = ? AND channel = ? AND msg REGEXP ? AND timestamp < ? AND mode = 0 ORDER BY timestamp DESC LIMIT ?'); + $sth->bind_param(1, $context_id); + $sth->bind_param(2, $message->{channel}); + $sth->bind_param(3, $regex); + $sth->bind_param(4, $message->{timestamp}); + $sth->bind_param(5, $count - 1); + } else { + $sth = $self->{dbh} + ->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE channel = ? AND msg REGEXP ? AND timestamp < ? AND mode = 0 ORDER BY timestamp DESC LIMIT ?'); + $sth->bind_param(1, $message->{channel}); + $sth->bind_param(2, $regex); + $sth->bind_param(3, $message->{timestamp}); + $sth->bind_param(4, $count - 1); + } + $sth->execute(); + return [reverse @{$sth->fetchall_arrayref({})}]; + }; + $self->{pbot}->{logger}->log($@) if $@; + } + + if (defined $before and $before > 0) { + $messages_before = eval { + my $sth; + if (defined $context_id) { + $sth = $self->{dbh} + ->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE id = ? AND channel = ? AND timestamp < ? AND mode = 0 ORDER BY timestamp DESC LIMIT ?'); + $sth->bind_param(1, $context_id); + $sth->bind_param(2, $message->{channel}); + $sth->bind_param(3, $message->{timestamp}); + $sth->bind_param(4, $before); + } else { + $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE channel = ? AND timestamp < ? AND mode = 0 ORDER BY timestamp DESC LIMIT ?'); + $sth->bind_param(1, $message->{channel}); + $sth->bind_param(2, $message->{timestamp}); + $sth->bind_param(3, $before); + } + $sth->execute(); + return [reverse @{$sth->fetchall_arrayref({})}]; + }; + $self->{pbot}->{logger}->log($@) if $@; + } + + if (defined $after and $after > 0) { + $messages_after = eval { + my $sth; + if (defined $context_id) { + $sth = $self->{dbh} + ->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE id = ? AND channel = ? AND timestamp > ? AND mode = 0 ORDER BY timestamp ASC LIMIT ?'); + $sth->bind_param(1, $context_id); + $sth->bind_param(2, $message->{channel}); + $sth->bind_param(3, $message->{timestamp}); + $sth->bind_param(4, $after); + } else { + $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE channel = ? AND timestamp > ? AND mode = 0 ORDER BY timestamp ASC LIMIT ?'); + $sth->bind_param(1, $message->{channel}); + $sth->bind_param(2, $message->{timestamp}); + $sth->bind_param(3, $after); + } + $sth->execute(); + return $sth->fetchall_arrayref({}); + }; + $self->{pbot}->{logger}->log($@) if $@; + } + + my @messages; + push(@messages, @$messages_before) if defined $messages_before; + push(@messages, @$messages_count) if defined $messages_count; + push(@messages, $message); + push(@messages, @$messages_after) if defined $messages_after; + + my %nicks; + foreach my $msg (@messages) { + if (not exists $nicks{$msg->{id}}) { + my $hostmask = $self->find_most_recent_hostmask($msg->{id}); + my ($nick) = $hostmask =~ m/^([^!]+)/; + $nicks{$msg->{id}} = $nick; + } + $msg->{nick} = $nicks{$msg->{id}}; + } + + return \@messages; +} + +sub recall_message_by_count { + my ($self, $id, $channel, $count, $ignore_command, $use_aliases) = @_; + + my $messages; + + if (defined $id) { + $messages = eval { + if (defined $use_aliases) { + my %akas = $self->get_also_known_as($use_aliases); + my %seen_id; + my $ids; + my $or = ''; + foreach my $aka (keys %akas) { + next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; + next if $akas{$aka}->{nickchange} == 1; + next if exists $seen_id{$akas{$aka}->{id}}; + $seen_id{$akas{$aka}->{id}} = 1; + + $ids .= "${or}id = ?"; + $or = ' OR '; + } + + my $sql = "SELECT id, msg, mode, timestamp, channel FROM Messages WHERE ($ids) AND channel = ? ORDER BY timestamp DESC LIMIT 10 OFFSET ?"; + my $sth = $self->{dbh}->prepare($sql); + + my $param = 1; + %seen_id = (); + foreach my $aka (keys %akas) { + next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; + next if $akas{$aka}->{nickchange} == 1; + next if exists $seen_id{$akas{$aka}->{id}}; + $seen_id{$akas{$aka}->{id}} = 1; + + $sth->bind_param($param++, $akas{$aka}->{id}); + } + + $sth->bind_param($param++, $channel); + $sth->bind_param($param++, $count); + $sth->execute(); + return $sth->fetchall_arrayref({}); + } else { + my $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE id = ? AND channel = ? ORDER BY timestamp DESC LIMIT 10 OFFSET ?'); + $sth->bind_param(1, $id); + $sth->bind_param(2, $channel); + $sth->bind_param(3, $count); + $sth->execute(); + return $sth->fetchall_arrayref({}); + } + }; + } else { + $messages = eval { + my $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE channel = ? ORDER BY timestamp DESC LIMIT 10 OFFSET ?'); + $sth->execute($channel, $count); + return $sth->fetchall_arrayref({}); + }; + } + + $self->{pbot}->{logger}->log($@) if $@; + + if (defined $ignore_command) { + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + my $bot_trigger = $self->{pbot}->{registry}->get_value('general', 'trigger'); + foreach my $message (@$messages) { + next if $message->{msg} =~ m/^$botnick.? $ignore_command/ or $message->{msg} =~ m/^$bot_trigger$ignore_command/; + return $message; + } + return undef; + } + return $messages->[0]; +} + +sub recall_message_by_text { + my ($self, $id, $channel, $text, $ignore_command) = @_; - if (defined $count and $count > 1) { my $regex = '(?i)'; $regex .= ($text =~ m/^\w/) ? '\b' : '\B'; $regex .= quotemeta $text; $regex .= ($text =~ m/\w$/) ? '\b' : '\B'; $regex =~ s/\\\*/.*?/g; - $messages_count = eval { - my $sth; - if (defined $context_id) { - $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE id = ? AND channel = ? AND msg REGEXP ? AND timestamp < ? AND mode = 0 ORDER BY timestamp DESC LIMIT ?'); - $sth->bind_param(1, $context_id); - $sth->bind_param(2, $message->{channel}); - $sth->bind_param(3, $regex); - $sth->bind_param(4, $message->{timestamp}); - $sth->bind_param(5, $count - 1); - } else { - $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE channel = ? AND msg REGEXP ? AND timestamp < ? AND mode = 0 ORDER BY timestamp DESC LIMIT ?'); - $sth->bind_param(1, $message->{channel}); - $sth->bind_param(2, $regex); - $sth->bind_param(3, $message->{timestamp}); - $sth->bind_param(4, $count - 1); - } - $sth->execute(); - return [reverse @{$sth->fetchall_arrayref({})}]; - }; - $self->{pbot}->{logger}->log($@) if $@; - } + my $messages; - if (defined $before and $before > 0) { - $messages_before = eval { - my $sth; - if (defined $context_id) { - $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE id = ? AND channel = ? AND timestamp < ? AND mode = 0 ORDER BY timestamp DESC LIMIT ?'); - $sth->bind_param(1, $context_id); - $sth->bind_param(2, $message->{channel}); - $sth->bind_param(3, $message->{timestamp}); - $sth->bind_param(4, $before); - } else { - $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE channel = ? AND timestamp < ? AND mode = 0 ORDER BY timestamp DESC LIMIT ?'); - $sth->bind_param(1, $message->{channel}); - $sth->bind_param(2, $message->{timestamp}); - $sth->bind_param(3, $before); - } - $sth->execute(); - return [reverse @{$sth->fetchall_arrayref({})}]; - }; - $self->{pbot}->{logger}->log($@) if $@; - } - - if (defined $after and $after > 0) { - $messages_after = eval { - my $sth; - if (defined $context_id) { - $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE id = ? AND channel = ? AND timestamp > ? AND mode = 0 ORDER BY timestamp ASC LIMIT ?'); - $sth->bind_param(1, $context_id); - $sth->bind_param(2, $message->{channel}); - $sth->bind_param(3, $message->{timestamp}); - $sth->bind_param(4, $after); - } else { - $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE channel = ? AND timestamp > ? AND mode = 0 ORDER BY timestamp ASC LIMIT ?'); - $sth->bind_param(1, $message->{channel}); - $sth->bind_param(2, $message->{timestamp}); - $sth->bind_param(3, $after); - } - $sth->execute(); - return $sth->fetchall_arrayref({}); - }; - $self->{pbot}->{logger}->log($@) if $@; - } - - my @messages; - push(@messages, @$messages_before) if defined $messages_before; - push(@messages, @$messages_count) if defined $messages_count; - push(@messages, $message); - push(@messages, @$messages_after) if defined $messages_after; - - my %nicks; - foreach my $msg (@messages) { - if (not exists $nicks{$msg->{id}}) { - my $hostmask = $self->find_most_recent_hostmask($msg->{id}); - my ($nick) = $hostmask =~ m/^([^!]+)/; - $nicks{$msg->{id}} = $nick; + if (defined $id) { + $messages = eval { + my $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE id = ? AND channel = ? AND msg REGEXP ? ORDER BY timestamp DESC LIMIT 10'); + $sth->execute($id, $channel, $regex); + return $sth->fetchall_arrayref({}); + }; + } else { + $messages = eval { + my $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE channel = ? AND msg REGEXP ? ORDER BY timestamp DESC LIMIT 10'); + $sth->execute($channel, $regex); + return $sth->fetchall_arrayref({}); + }; } - $msg->{nick} = $nicks{$msg->{id}}; - } - return \@messages; -} + $self->{pbot}->{logger}->log($@) if $@; -sub recall_message_by_count { - my ($self, $id, $channel, $count, $ignore_command, $use_aliases) = @_; - - my $messages; - - if (defined $id) { - $messages = eval { - if (defined $use_aliases) { - my %akas = $self->get_also_known_as($use_aliases); - my %seen_id; - my $ids; - my $or = ''; - foreach my $aka (keys %akas) { - next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; - next if $akas{$aka}->{nickchange} == 1; - next if exists $seen_id{$akas{$aka}->{id}}; - $seen_id{$akas{$aka}->{id}} = 1; - - $ids .= "${or}id = ?"; - $or = ' OR '; + if (defined $ignore_command) { + my $bot_trigger = $self->{pbot}->{registry}->get_value('general', 'trigger'); + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + foreach my $message (@$messages) { + next + if $message->{msg} =~ m/^$botnick.? $ignore_command/i + or $message->{msg} =~ m/^(?:\s*[^,:\(\)\+\*\/ ]+[,:]?\s+)?$bot_trigger$ignore_command/i + or $message->{msg} =~ m/^\s*$ignore_command.? $botnick$/i; + return $message; } - - my $sql = "SELECT id, msg, mode, timestamp, channel FROM Messages WHERE ($ids) AND channel = ? ORDER BY timestamp DESC LIMIT 10 OFFSET ?"; - my $sth = $self->{dbh}->prepare($sql); - - my $param = 1; - %seen_id = (); - foreach my $aka (keys %akas) { - next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; - next if $akas{$aka}->{nickchange} == 1; - next if exists $seen_id{$akas{$aka}->{id}}; - $seen_id{$akas{$aka}->{id}} = 1; - - $sth->bind_param($param++, $akas{$aka}->{id}); - } - - $sth->bind_param($param++, $channel); - $sth->bind_param($param++, $count); - $sth->execute(); - return $sth->fetchall_arrayref({}); - } else { - my $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE id = ? AND channel = ? ORDER BY timestamp DESC LIMIT 10 OFFSET ?'); - $sth->bind_param(1, $id); - $sth->bind_param(2, $channel); - $sth->bind_param(3, $count); - $sth->execute(); - return $sth->fetchall_arrayref({}); - } - }; - } else { - $messages = eval { - my $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE channel = ? ORDER BY timestamp DESC LIMIT 10 OFFSET ?'); - $sth->execute($channel, $count); - return $sth->fetchall_arrayref({}); - }; - } - - $self->{pbot}->{logger}->log($@) if $@; - - if (defined $ignore_command) { - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - my $bot_trigger = $self->{pbot}->{registry}->get_value('general', 'trigger'); - foreach my $message (@$messages) { - next if $message->{msg} =~ m/^$botnick.? $ignore_command/ or $message->{msg} =~ m/^$bot_trigger$ignore_command/; - return $message; + return undef; } - return undef; - } - return $messages->[0]; -} - -sub recall_message_by_text { - my ($self, $id, $channel, $text, $ignore_command) = @_; - - my $regex = '(?i)'; - $regex .= ($text =~ m/^\w/) ? '\b' : '\B'; - $regex .= quotemeta $text; - $regex .= ($text =~ m/\w$/) ? '\b' : '\B'; - $regex =~ s/\\\*/.*?/g; - - my $messages; - - if (defined $id) { - $messages = eval { - my $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE id = ? AND channel = ? AND msg REGEXP ? ORDER BY timestamp DESC LIMIT 10'); - $sth->execute($id, $channel, $regex); - return $sth->fetchall_arrayref({}); - }; - } else { - $messages = eval { - my $sth = $self->{dbh}->prepare('SELECT id, msg, mode, timestamp, channel FROM Messages WHERE channel = ? AND msg REGEXP ? ORDER BY timestamp DESC LIMIT 10'); - $sth->execute($channel, $regex); - return $sth->fetchall_arrayref({}); - }; - } - - $self->{pbot}->{logger}->log($@) if $@; - - if (defined $ignore_command) { - my $bot_trigger = $self->{pbot}->{registry}->get_value('general', 'trigger'); - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - foreach my $message (@$messages) { - next if $message->{msg} =~ m/^$botnick.? $ignore_command/i or $message->{msg} =~ m/^(?:\s*[^,:\(\)\+\*\/ ]+[,:]?\s+)?$bot_trigger$ignore_command/i or $message->{msg} =~ m/^\s*$ignore_command.? $botnick$/i; - return $message; - } - return undef; - } - return $messages->[0]; + return $messages->[0]; } sub get_max_messages { - my ($self, $id, $channel, $use_aliases) = @_; + my ($self, $id, $channel, $use_aliases) = @_; - my $count = eval { - my $sql = "SELECT COUNT(*) FROM Messages WHERE channel = ? AND "; + my $count = eval { + my $sql = "SELECT COUNT(*) FROM Messages WHERE channel = ? AND "; - my %akas; - if (defined $use_aliases) { - %akas = $self->get_also_known_as($use_aliases); - } else { - $akas{'this'} = { id => $id, type => $self->{alias_type}->{STRONG}, nickchange => 0 }; - } + my %akas; + if (defined $use_aliases) { %akas = $self->get_also_known_as($use_aliases); } + else { $akas{'this'} = {id => $id, type => $self->{alias_type}->{STRONG}, nickchange => 0}; } - my $ids; - my %seen_id; - my $or = ''; - foreach my $aka (keys %akas) { - next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; - next if $akas{$aka}->{nickchange} == 1; - next if exists $seen_id{$akas{$aka}->{id}}; - $seen_id{$akas{$aka}->{id}} = 1; + my $ids; + my %seen_id; + my $or = ''; + foreach my $aka (keys %akas) { + next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; + next if $akas{$aka}->{nickchange} == 1; + next if exists $seen_id{$akas{$aka}->{id}}; + $seen_id{$akas{$aka}->{id}} = 1; - $ids .= "${or}id = ?"; - $or = ' OR '; - } + $ids .= "${or}id = ?"; + $or = ' OR '; + } - $sql .= "($ids)"; + $sql .= "($ids)"; - my $sth = $self->{dbh}->prepare($sql); - my $param = 1; - $sth->bind_param($param++, $channel); + my $sth = $self->{dbh}->prepare($sql); + my $param = 1; + $sth->bind_param($param++, $channel); - %seen_id = (); - foreach my $aka (keys %akas) { - next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; - next if $akas{$aka}->{nickchange} == 1; - next if exists $seen_id{$akas{$aka}->{id}}; - $seen_id{$akas{$aka}->{id}} = 1; + %seen_id = (); + foreach my $aka (keys %akas) { + next if $akas{$aka}->{type} == $self->{alias_type}->{WEAK}; + next if $akas{$aka}->{nickchange} == 1; + next if exists $seen_id{$akas{$aka}->{id}}; + $seen_id{$akas{$aka}->{id}} = 1; - $sth->bind_param($param++, $akas{$aka}->{id}); - } + $sth->bind_param($param++, $akas{$aka}->{id}); + } - $sth->execute(); - my $row = $sth->fetchrow_hashref(); - $sth->finish(); - return $row->{'COUNT(*)'}; - }; - $self->{pbot}->{logger}->log($@) if $@; - $count = 0 if not defined $count; - return $count; + $sth->execute(); + my $row = $sth->fetchrow_hashref(); + $sth->finish(); + return $row->{'COUNT(*)'}; + }; + $self->{pbot}->{logger}->log($@) if $@; + $count = 0 if not defined $count; + return $count; } sub create_channel { - my ($self, $id, $channel) = @_; + my ($self, $id, $channel) = @_; - eval { - my $sth = $self->{dbh}->prepare('INSERT OR IGNORE INTO Channels VALUES (?, ?, 0, 0, 0, 0, 0, 0, 0, 0)'); - my $rv = $sth->execute($id, $channel); - $self->{new_entries}++; - }; - $self->{pbot}->{logger}->log($@) if $@; + eval { + my $sth = $self->{dbh}->prepare('INSERT OR IGNORE INTO Channels VALUES (?, ?, 0, 0, 0, 0, 0, 0, 0, 0)'); + my $rv = $sth->execute($id, $channel); + $self->{new_entries}++; + }; + $self->{pbot}->{logger}->log($@) if $@; } sub get_channels { - my ($self, $id) = @_; + my ($self, $id) = @_; - my $channels = eval { - my $sth = $self->{dbh}->prepare('SELECT channel FROM Channels WHERE id = ?'); - $sth->execute($id); - return $sth->fetchall_arrayref(); - }; - $self->{pbot}->{logger}->log($@) if $@; - return map {$_->[0]} @$channels; + my $channels = eval { + my $sth = $self->{dbh}->prepare('SELECT channel FROM Channels WHERE id = ?'); + $sth->execute($id); + return $sth->fetchall_arrayref(); + }; + $self->{pbot}->{logger}->log($@) if $@; + return map { $_->[0] } @$channels; } sub get_channel_data { - my ($self, $id, $channel, @columns) = @_; + my ($self, $id, $channel, @columns) = @_; - $self->create_channel($id, $channel); + $self->create_channel($id, $channel); - my $channel_data = eval { - my $sql = 'SELECT '; + my $channel_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 Channels WHERE id = ? AND channel = ?'; - my $sth = $self->{dbh}->prepare($sql); - $sth->execute($id, $channel); - return $sth->fetchrow_hashref(); - }; - $self->{pbot}->{logger}->log($@) if $@; - return $channel_data; + $sql .= ' FROM Channels WHERE id = ? AND channel = ?'; + my $sth = $self->{dbh}->prepare($sql); + $sth->execute($id, $channel); + return $sth->fetchrow_hashref(); + }; + $self->{pbot}->{logger}->log($@) if $@; + return $channel_data; } sub update_channel_data { - my ($self, $id, $channel, $data) = @_; + my ($self, $id, $channel, $data) = @_; - $self->create_channel($id, $channel); + $self->create_channel($id, $channel); - eval { - my $sql = 'UPDATE Channels SET '; + eval { + my $sql = 'UPDATE Channels 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 = ? AND channel = ?'; + $sql .= ' WHERE id = ? AND channel = ?'; - 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->bind_param($param, $channel); - $sth->execute(); - $self->{new_entries}++; - }; - $self->{pbot}->{logger}->log($@) if $@; + $sth->bind_param($param++, $id); + $sth->bind_param($param, $channel); + $sth->execute(); + $self->{new_entries}++; + }; + $self->{pbot}->{logger}->log($@) if $@; } sub get_channel_datas_where_last_offense_older_than { - my ($self, $timestamp) = @_; + my ($self, $timestamp) = @_; - my $channel_datas = eval { - my $sth = $self->{dbh}->prepare('SELECT id, channel, offenses, last_offense, unbanmes FROM Channels WHERE last_offense > 0 AND last_offense <= ?'); - $sth->execute($timestamp); - return $sth->fetchall_arrayref({}); - }; - $self->{pbot}->{logger}->log($@) if $@; - return $channel_datas; + my $channel_datas = eval { + my $sth = $self->{dbh}->prepare('SELECT id, channel, offenses, last_offense, unbanmes FROM Channels WHERE last_offense > 0 AND last_offense <= ?'); + $sth->execute($timestamp); + return $sth->fetchall_arrayref({}); + }; + $self->{pbot}->{logger}->log($@) if $@; + return $channel_datas; } sub get_channel_datas_with_enter_abuses { - my ($self) = @_; + my ($self) = @_; - my $channel_datas = eval { - my $sth = $self->{dbh}->prepare('SELECT id, channel, enter_abuses, last_offense FROM Channels WHERE enter_abuses > 0'); - $sth->execute(); - return $sth->fetchall_arrayref({}); - }; - $self->{pbot}->{logger}->log($@) if $@; - return $channel_datas; + my $channel_datas = eval { + my $sth = $self->{dbh}->prepare('SELECT id, channel, enter_abuses, last_offense FROM Channels WHERE enter_abuses > 0'); + $sth->execute(); + return $sth->fetchall_arrayref({}); + }; + $self->{pbot}->{logger}->log($@) if $@; + return $channel_datas; } sub devalidate_channel { - my ($self, $id, $channel, $mode) = @_; + my ($self, $id, $channel, $mode) = @_; - $mode = 0 if not defined $mode; + $mode = 0 if not defined $mode; - eval { - my $sth = $self->{dbh}->prepare("UPDATE Channels SET validated = ? WHERE id = ? AND channel = ?"); - $sth->execute($mode, $id, $channel); - $self->{new_entries}++; - }; - $self->{pbot}->{logger}->log($@) if $@; + eval { + my $sth = $self->{dbh}->prepare("UPDATE Channels SET validated = ? WHERE id = ? AND channel = ?"); + $sth->execute($mode, $id, $channel); + $self->{new_entries}++; + }; + $self->{pbot}->{logger}->log($@) if $@; } sub devalidate_all_channels { - my ($self, $id, $mode) = @_; + my ($self, $id, $mode) = @_; - $mode = 0 if not defined $mode; + $mode = 0 if not defined $mode; - my $where = ''; - $where = 'WHERE id = ?' if defined $id; + my $where = ''; + $where = 'WHERE id = ?' if defined $id; - eval { - my $sth = $self->{dbh}->prepare("UPDATE Channels SET validated = ? $where"); - $sth->bind_param(1, $mode); - $sth->bind_param(2, $id) if defined $id; - $sth->execute(); - $self->{new_entries}++; - }; - $self->{pbot}->{logger}->log($@) if $@; + eval { + my $sth = $self->{dbh}->prepare("UPDATE Channels SET validated = ? $where"); + $sth->bind_param(1, $mode); + $sth->bind_param(2, $id) if defined $id; + $sth->execute(); + $self->{new_entries}++; + }; + $self->{pbot}->{logger}->log($@) if $@; } sub link_aliases { - my ($self, $account, $hostmask, $nickserv) = @_; + my ($self, $account, $hostmask, $nickserv) = @_; - my $debug_link = $self->{pbot}->{registry}->get_value('messagehistory', 'debug_link'); + my $debug_link = $self->{pbot}->{registry}->get_value('messagehistory', 'debug_link'); - $self->{pbot}->{logger}->log("Linking [$account][" . ($hostmask?$hostmask:'undef') . "][" . ($nickserv?$nickserv:'undef') . "]\n") if $debug_link >= 3; + $self->{pbot}->{logger}->log("Linking [$account][" . ($hostmask ? $hostmask : 'undef') . "][" . ($nickserv ? $nickserv : 'undef') . "]\n") if $debug_link >= 3; - eval { - my %ids; + eval { + my %ids; - if ($hostmask) { - my ($nick, $host) = $hostmask =~ /^([^!]+)![^@]+@(.*)$/; - my $sth = $self->{dbh}->prepare('SELECT id, last_seen FROM Hostmasks WHERE host = ?'); - $sth->execute($host); - my $rows = $sth->fetchall_arrayref({}); + if ($hostmask) { + my ($nick, $host) = $hostmask =~ /^([^!]+)![^@]+@(.*)$/; + my $sth = $self->{dbh}->prepare('SELECT id, last_seen FROM Hostmasks WHERE host = ?'); + $sth->execute($host); + my $rows = $sth->fetchall_arrayref({}); - my $now = gettimeofday; + my $now = gettimeofday; - foreach my $row (@$rows) { - my $idhost = $self->find_most_recent_hostmask($row->{id}) if $debug_link >= 2 && $row->{id} != $account; - if ($now - $row->{last_seen} <= 60 * 60 * 48) { - $ids{$row->{id}} = { id => $row->{id}, type => $self->{alias_type}->{STRONG}, force => 1 }; - $self->{pbot}->{logger}->log("found STRONG matching id $row->{id} ($idhost) for host [$host]\n") if $debug_link >= 2 && $row->{id} != $account; - } else { - $ids{$row->{id}} = { id => $row->{id}, type => $self->{alias_type}->{WEAK} }; - $self->{pbot}->{logger}->log("found WEAK matching id $row->{id} ($idhost) for host [$host]\n") if $debug_link >= 2 && $row->{id} != $account; - } - } - - unless ($nick =~ m/^Guest\d+$/) { - my $sth = $self->{dbh}->prepare('SELECT id, hostmask FROM Hostmasks WHERE nick = ?'); - $sth->execute($nick); - my $rows = $sth->fetchall_arrayref({}); - - my ($account1) = $host =~ m{/([^/]+)$}; - $account1 = '' if not defined $account1; - - my $hostip = undef; - if ($host =~ m/(\d+[[:punct:]]\d+[[:punct:]]\d+[[:punct:]]\d+)\D/) { - $hostip = $1; - $hostip =~ s/[[:punct:]]/./g; - } - - foreach my $row (@$rows) { - next if $row->{id} == $account; - $self->{pbot}->{logger}->log("Processing row $row->{hostmask}\n"); - my ($thost) = $row->{hostmask} =~ m/@(.*)$/; - - if ($thost =~ m{/}) { - my ($account2) = $thost =~ m{/([^/]+)$}; - - if ($account1 ne $account2) { - $self->{pbot}->{logger}->log("Skipping non-matching cloaked hosts: $host vs $thost\n"); - next; - } else { - $self->{pbot}->{logger}->log("Cloaked hosts match: $host vs $thost\n"); - $ids{$row->{id}} = { id => $row->{id}, type => $self->{alias_type}->{STRONG}, force => 1 }; + foreach my $row (@$rows) { + my $idhost = $self->find_most_recent_hostmask($row->{id}) if $debug_link >= 2 && $row->{id} != $account; + if ($now - $row->{last_seen} <= 60 * 60 * 48) { + $ids{$row->{id}} = {id => $row->{id}, type => $self->{alias_type}->{STRONG}, force => 1}; + $self->{pbot}->{logger}->log("found STRONG matching id $row->{id} ($idhost) for host [$host]\n") if $debug_link >= 2 && $row->{id} != $account; + } else { + $ids{$row->{id}} = {id => $row->{id}, type => $self->{alias_type}->{WEAK}}; + $self->{pbot}->{logger}->log("found WEAK matching id $row->{id} ($idhost) for host [$host]\n") if $debug_link >= 2 && $row->{id} != $account; + } } - } - my $distance = fastdistance($host, $thost); - my $length = (length($host) > length($thost)) ? length $host : length $thost; + unless ($nick =~ m/^Guest\d+$/) { + my $sth = $self->{dbh}->prepare('SELECT id, hostmask FROM Hostmasks WHERE nick = ?'); + $sth->execute($nick); + my $rows = $sth->fetchall_arrayref({}); - #$self->{pbot}->{logger}->log("distance: " . ($distance / $length) . " -- $host vs $thost\n") if $length != 0; + my ($account1) = $host =~ m{/([^/]+)$}; + $account1 = '' if not defined $account1; - if ($length != 0 && $distance / $length < 0.50) { - $self->{pbot}->{logger}->log("11: distance match: $host vs $thost == " . ($distance / $length) . "\n"); - $ids{$row->{id}} = { id => $row->{id}, type => $self->{alias_type}->{STRONG} }; # don't force linking - $self->{pbot}->{logger}->log("found STRONG matching id $row->{id} ($row->{hostmask}) for nick [$nick]\n") if $debug_link >= 2; - } else { - # handle cases like 99.57.140.149 vs 99-57-140-149.lightspeed.sntcca.sbcglobal.net - if (defined $hostip) { - if ($hostip eq $thost) { - $ids{$row->{id}} = { id => $row->{id}, type => $self->{alias_type}->{STRONG} }; # don't force linking - $self->{pbot}->{logger}->log("IP vs hostname match: $host vs $thost\n"); - } - } elsif ($thost =~ m/(\d+[[:punct:]]\d+[[:punct:]]\d+[[:punct:]]\d+)\D/) { - my $thostip = $1; - $thostip =~ s/[[:punct:]]/./g; - if ($thostip eq $host) { - $ids{$row->{id}} = { id => $row->{id}, type => $self->{alias_type}->{STRONG} }; # don't force linking - $self->{pbot}->{logger}->log("IP vs hostname match: $host vs $thost\n"); - } + my $hostip = undef; + if ($host =~ m/(\d+[[:punct:]]\d+[[:punct:]]\d+[[:punct:]]\d+)\D/) { + $hostip = $1; + $hostip =~ s/[[:punct:]]/./g; + } + + foreach my $row (@$rows) { + next if $row->{id} == $account; + $self->{pbot}->{logger}->log("Processing row $row->{hostmask}\n"); + my ($thost) = $row->{hostmask} =~ m/@(.*)$/; + + if ($thost =~ m{/}) { + my ($account2) = $thost =~ m{/([^/]+)$}; + + if ($account1 ne $account2) { + $self->{pbot}->{logger}->log("Skipping non-matching cloaked hosts: $host vs $thost\n"); + next; + } else { + $self->{pbot}->{logger}->log("Cloaked hosts match: $host vs $thost\n"); + $ids{$row->{id}} = {id => $row->{id}, type => $self->{alias_type}->{STRONG}, force => 1}; + } + } + + my $distance = fastdistance($host, $thost); + my $length = (length($host) > length($thost)) ? length $host : length $thost; + + #$self->{pbot}->{logger}->log("distance: " . ($distance / $length) . " -- $host vs $thost\n") if $length != 0; + + if ($length != 0 && $distance / $length < 0.50) { + $self->{pbot}->{logger}->log("11: distance match: $host vs $thost == " . ($distance / $length) . "\n"); + $ids{$row->{id}} = {id => $row->{id}, type => $self->{alias_type}->{STRONG}}; # don't force linking + $self->{pbot}->{logger}->log("found STRONG matching id $row->{id} ($row->{hostmask}) for nick [$nick]\n") if $debug_link >= 2; + } else { + + # handle cases like 99.57.140.149 vs 99-57-140-149.lightspeed.sntcca.sbcglobal.net + if (defined $hostip) { + if ($hostip eq $thost) { + $ids{$row->{id}} = {id => $row->{id}, type => $self->{alias_type}->{STRONG}}; # don't force linking + $self->{pbot}->{logger}->log("IP vs hostname match: $host vs $thost\n"); + } + } elsif ($thost =~ m/(\d+[[:punct:]]\d+[[:punct:]]\d+[[:punct:]]\d+)\D/) { + my $thostip = $1; + $thostip =~ s/[[:punct:]]/./g; + if ($thostip eq $host) { + $ids{$row->{id}} = {id => $row->{id}, type => $self->{alias_type}->{STRONG}}; # don't force linking + $self->{pbot}->{logger}->log("IP vs hostname match: $host vs $thost\n"); + } + } + } + } } - } } - } - } - if ($nickserv) { - my $sth = $self->{dbh}->prepare('SELECT id FROM Nickserv WHERE nickserv = ?'); - $sth->execute($nickserv); - my $rows = $sth->fetchall_arrayref({}); + if ($nickserv) { + my $sth = $self->{dbh}->prepare('SELECT id FROM Nickserv WHERE nickserv = ?'); + $sth->execute($nickserv); + my $rows = $sth->fetchall_arrayref({}); - foreach my $row (@$rows) { - my $idhost = $self->find_most_recent_hostmask($row->{id}) if $debug_link >= 2 && $row->{id} != $account; - $ids{$row->{id}} = { id => $row->{id}, type => $self->{alias_type}->{STRONG}, force => 1 }; - $self->{pbot}->{logger}->log("12: found STRONG matching id $row->{id} ($idhost) for nickserv [$nickserv]\n") if $debug_link >= 2 && $row->{id} != $account; - } - } + foreach my $row (@$rows) { + my $idhost = $self->find_most_recent_hostmask($row->{id}) if $debug_link >= 2 && $row->{id} != $account; + $ids{$row->{id}} = {id => $row->{id}, type => $self->{alias_type}->{STRONG}, force => 1}; + $self->{pbot}->{logger}->log("12: found STRONG matching id $row->{id} ($idhost) for nickserv [$nickserv]\n") if $debug_link >= 2 && $row->{id} != $account; + } + } - foreach my $id (sort keys %ids) { - next if $account == $id; - $self->link_alias($account, $id, $ids{$id}->{type}, $ids{$id}->{force}); - } - }; - $self->{pbot}->{logger}->log($@) if $@; + foreach my $id (sort keys %ids) { + next if $account == $id; + $self->link_alias($account, $id, $ids{$id}->{type}, $ids{$id}->{force}); + } + }; + $self->{pbot}->{logger}->log($@) if $@; } sub link_alias { - my ($self, $id, $alias, $type, $force) = @_; + my ($self, $id, $alias, $type, $force) = @_; - my $debug_link = $self->{pbot}->{registry}->get_value('messagehistory', 'debug_link'); + my $debug_link = $self->{pbot}->{registry}->get_value('messagehistory', 'debug_link'); - $self->{pbot}->{logger}->log("Attempting to " . ($force ? "forcefully " : "") . ($type == $self->{alias_type}->{STRONG} ? "strongly" : "weakly") . " link $id to $alias\n") if $debug_link >= 3; + $self->{pbot}->{logger} + ->log("Attempting to " . ($force ? "forcefully " : "") . ($type == $self->{alias_type}->{STRONG} ? "strongly" : "weakly") . " link $id to $alias\n") + if $debug_link >= 3; - my $ret = eval { - my $sth = $self->{dbh}->prepare('SELECT type FROM Aliases WHERE id = ? AND alias = ? LIMIT 1'); - $sth->execute($alias, $id); + my $ret = eval { + my $sth = $self->{dbh}->prepare('SELECT type FROM Aliases WHERE id = ? AND alias = ? LIMIT 1'); + $sth->execute($alias, $id); - my $row = $sth->fetchrow_hashref(); + my $row = $sth->fetchrow_hashref(); - if (defined $row) { - if ($force) { - if ($row->{'type'} != $type) { - $self->{pbot}->{logger}->log("$id already " . ($row->{'type'} == $self->{alias_type}->{STRONG} ? "strongly" : "weakly") . " linked to $alias, forcing override\n") if $debug_link >= 1; + if (defined $row) { + if ($force) { + if ($row->{'type'} != $type) { + $self->{pbot}->{logger}->log("$id already " . ($row->{'type'} == $self->{alias_type}->{STRONG} ? "strongly" : "weakly") . " linked to $alias, forcing override\n") + if $debug_link >= 1; - $sth = $self->{dbh}->prepare('UPDATE Aliases SET type = ? WHERE alias = ? AND id = ?'); - $sth->execute($type, $id, $alias); - $sth->execute($type, $alias, $id); - return 1; - } else { - $self->{pbot}->{logger}->log("$id already " . ($row->{'type'} == $self->{alias_type}->{STRONG} ? "strongly" : "weakly") . " linked to $alias, ignoring\n") if $debug_link >= 4; - return 0; + $sth = $self->{dbh}->prepare('UPDATE Aliases SET type = ? WHERE alias = ? AND id = ?'); + $sth->execute($type, $id, $alias); + $sth->execute($type, $alias, $id); + return 1; + } else { + $self->{pbot}->{logger}->log("$id already " . ($row->{'type'} == $self->{alias_type}->{STRONG} ? "strongly" : "weakly") . " linked to $alias, ignoring\n") + if $debug_link >= 4; + return 0; + } + } else { + $self->{pbot}->{logger}->log("$id already " . ($row->{'type'} == $self->{alias_type}->{STRONG} ? "strongly" : "weakly") . " linked to $alias, ignoring\n") + if $debug_link >= 4; + return 0; + } + } + + $sth = $self->{dbh}->prepare('INSERT INTO Aliases VALUES (?, ?, ?)'); + $sth->execute($alias, $id, $type); + $sth->execute($id, $alias, $type); + return 1; + }; + $self->{pbot}->{logger}->log($@) if $@; + + my $host1 = $self->find_most_recent_hostmask($id); + my $host2 = $self->find_most_recent_hostmask($alias); + + $self->{pbot}->{logger}->log(($type == $self->{alias_type}->{STRONG} ? "Strongly" : "Weakly") . " linked $id ($host1) to $alias ($host2).\n") if $ret and $debug_link; + + if ($ret) { + $host1 = lc $host1; + $host2 = lc $host2; + my ($nick1) = $host1 =~ m/^([^!]+)!/; + my ($nick2) = $host2 =~ m/^([^!]+)!/; + my $distance = fastdistance($nick1, $nick2); + my $length = (length $nick1 > length $nick2) ? length $nick1 : length $nick2; + if ($distance > 1 && ($nick1 !~ /^guest/ && $nick2 !~ /^guest/) && ($host1 !~ /unaffiliated/ || $host2 !~ /unaffiliated/)) { + $self->{pbot}->{logger}->log("[$nick1][$nick2] $distance / $length\n"); + $self->{pbot}->{logger}->log("Possible bogus link: ($id) $host1 vs ($alias) $host2\n"); } - } else { - $self->{pbot}->{logger}->log("$id already " . ($row->{'type'} == $self->{alias_type}->{STRONG} ? "strongly" : "weakly") . " linked to $alias, ignoring\n") if $debug_link >= 4; - return 0; - } } - $sth = $self->{dbh}->prepare('INSERT INTO Aliases VALUES (?, ?, ?)'); - $sth->execute($alias, $id, $type); - $sth->execute($id, $alias, $type); - return 1; - }; - $self->{pbot}->{logger}->log($@) if $@; - - my $host1 = $self->find_most_recent_hostmask($id); - my $host2 = $self->find_most_recent_hostmask($alias); - - $self->{pbot}->{logger}->log(($type == $self->{alias_type}->{STRONG} ? "Strongly" : "Weakly") . " linked $id ($host1) to $alias ($host2).\n") if $ret and $debug_link; - - if ($ret) { - $host1 = lc $host1; - $host2 = lc $host2; - my ($nick1) = $host1 =~ m/^([^!]+)!/; - my ($nick2) = $host2 =~ m/^([^!]+)!/; - my $distance = fastdistance($nick1, $nick2); - my $length = (length $nick1 > length $nick2) ? length $nick1 : length $nick2; - if ($distance > 1 && ($nick1 !~ /^guest/ && $nick2 !~ /^guest/) && ($host1 !~ /unaffiliated/ || $host2 !~ /unaffiliated/)) { - $self->{pbot}->{logger}->log("[$nick1][$nick2] $distance / $length\n"); - $self->{pbot}->{logger}->log("Possible bogus link: ($id) $host1 vs ($alias) $host2\n"); - } - } - - return $ret; + return $ret; } sub unlink_alias { - my ($self, $id, $alias) = @_; + my ($self, $id, $alias) = @_; - my $ret = eval { - my $ret = 0; - my $sth = $self->{dbh}->prepare('DELETE FROM Aliases WHERE id = ? AND alias = ?'); - $sth->execute($id, $alias); - if ($sth->rows) { - $self->{new_entries}++; - $ret = 1; - } + my $ret = eval { + my $ret = 0; + my $sth = $self->{dbh}->prepare('DELETE FROM Aliases WHERE id = ? AND alias = ?'); + $sth->execute($id, $alias); + if ($sth->rows) { + $self->{new_entries}++; + $ret = 1; + } - $sth->execute($alias, $id); - if ($sth->rows) { - $self->{new_entries}++; - $ret = 1; - } else { - $ret = 0; - } + $sth->execute($alias, $id); + if ($sth->rows) { + $self->{new_entries}++; + $ret = 1; + } else { + $ret = 0; + } + return $ret; + }; + $self->{pbot}->{logger}->log($@) if $@; return $ret; - }; - $self->{pbot}->{logger}->log($@) if $@; - return $ret; } sub vacuum { - my $self = shift; + my $self = shift; - eval { - $self->{dbh}->commit(); - }; + eval { $self->{dbh}->commit(); }; - $self->{pbot}->{logger}->log("SQLite error $@ when committing $self->{new_entries} entries.\n") if $@; + $self->{pbot}->{logger}->log("SQLite error $@ when committing $self->{new_entries} entries.\n") if $@; - $self->{dbh}->do("VACUUM"); + $self->{dbh}->do("VACUUM"); - $self->{dbh}->begin_work(); - $self->{new_entries} = 0; + $self->{dbh}->begin_work(); + $self->{new_entries} = 0; } sub rebuild_aliases_table { - my $self = shift; + my $self = shift; - eval { - $self->{dbh}->do('DELETE FROM Aliases'); - $self->vacuum; + eval { + $self->{dbh}->do('DELETE FROM Aliases'); + $self->vacuum; - my $sth = $self->{dbh}->prepare('SELECT id, hostmask FROM Hostmasks ORDER BY id'); - $sth->execute(); - my $rows = $sth->fetchall_arrayref({}); + my $sth = $self->{dbh}->prepare('SELECT id, hostmask FROM Hostmasks ORDER BY id'); + $sth->execute(); + my $rows = $sth->fetchall_arrayref({}); - $sth = $self->{dbh}->prepare('SELECT nickserv FROM Nickserv WHERE id = ?'); + $sth = $self->{dbh}->prepare('SELECT nickserv FROM Nickserv WHERE id = ?'); - foreach my $row (@$rows) { - $self->{pbot}->{logger}->log("Link [$row->{id}][$row->{hostmask}]\n"); + foreach my $row (@$rows) { + $self->{pbot}->{logger}->log("Link [$row->{id}][$row->{hostmask}]\n"); - $self->link_aliases($row->{id}, $row->{hostmask}); + $self->link_aliases($row->{id}, $row->{hostmask}); - $sth->execute($row->{id}); - my $nrows = $sth->fetchall_arrayref({}); + $sth->execute($row->{id}); + my $nrows = $sth->fetchall_arrayref({}); - foreach my $nrow (@$nrows) { - $self->link_aliases($row->{id}, undef, $nrow->{nickserv}); - } - } - }; + foreach my $nrow (@$nrows) { $self->link_aliases($row->{id}, undef, $nrow->{nickserv}); } + } + }; - $self->{pbot}->{logger}->log($@) if $@; + $self->{pbot}->{logger}->log($@) if $@; } sub get_also_known_as { - my ($self, $nick, $dont_use_aliases_table) = @_; - my $debug = $self->{pbot}->{registry}->get_value('messagehistory', 'debug_aka'); + my ($self, $nick, $dont_use_aliases_table) = @_; + my $debug = $self->{pbot}->{registry}->get_value('messagehistory', 'debug_aka'); - $self->{pbot}->{logger}->log("Looking for AKAs for nick [$nick]\n") if $debug; + $self->{pbot}->{logger}->log("Looking for AKAs for nick [$nick]\n") if $debug; - my %akas = eval { - my (%akas, %hostmasks, %ids); + my %akas = eval { + my (%akas, %hostmasks, %ids); - unless ($dont_use_aliases_table) { - my ($id, $hostmask) = $self->find_message_account_by_nick($nick); + unless ($dont_use_aliases_table) { + my ($id, $hostmask) = $self->find_message_account_by_nick($nick); - if (not defined $id) { - return %akas; - } + if (not defined $id) { return %akas; } - $ids{$id} = { id => $id, type => $self->{alias_type}->{STRONG} }; - $self->{pbot}->{logger}->log("Adding $id -> $id\n") if $debug; + $ids{$id} = {id => $id, type => $self->{alias_type}->{STRONG}}; + $self->{pbot}->{logger}->log("Adding $id -> $id\n") if $debug; - my $sth = $self->{dbh}->prepare('SELECT alias, type FROM Aliases WHERE id = ?'); - $sth->execute($id); - my $rows = $sth->fetchall_arrayref({}); + my $sth = $self->{dbh}->prepare('SELECT alias, type FROM Aliases WHERE id = ?'); + $sth->execute($id); + my $rows = $sth->fetchall_arrayref({}); - foreach my $row (@$rows) { -# next if $row->{type} == $self->{alias_type}->{WEAK}; - $ids{$row->{alias}} = { id => $id, type => $row->{type} }; - $self->{pbot}->{logger}->log("[$id] 1) Adding $row->{alias} -> $id [type $row->{type}]\n") if $debug; - } + foreach my $row (@$rows) { - my %seen_id; - $sth = $self->{dbh}->prepare('SELECT id, type FROM Aliases WHERE alias = ?'); + # next if $row->{type} == $self->{alias_type}->{WEAK}; + $ids{$row->{alias}} = {id => $id, type => $row->{type}}; + $self->{pbot}->{logger}->log("[$id] 1) Adding $row->{alias} -> $id [type $row->{type}]\n") if $debug; + } - while (1) { - my $new_aliases = 0; + my %seen_id; + $sth = $self->{dbh}->prepare('SELECT id, type FROM Aliases WHERE alias = ?'); + + while (1) { + my $new_aliases = 0; + foreach my $id (keys %ids) { + next if $ids{$id}->{type} == $self->{alias_type}->{WEAK}; + next if exists $seen_id{$id}; + $seen_id{$id} = $id; + + $sth->execute($id); + my $rows = $sth->fetchall_arrayref({}); + + foreach my $row (@$rows) { + next if exists $ids{$row->{id}}; + + #next if $row->{type} == $self->{alias_type}->{WEAK}; + $ids{$row->{id}} = {id => $id, type => $ids{$id}->{type} == $self->{alias_type}->{WEAK} ? $self->{alias_type}->{WEAK} : $row->{type}}; + $new_aliases++; + $self->{pbot}->{logger}->log("[$id] 2) Adding $row->{id} -> $id [type $row->{type}]\n") if $debug; + } + } + last if not $new_aliases; + } + + my $hostmask_sth = $self->{dbh}->prepare('SELECT hostmask, nickchange FROM Hostmasks WHERE id = ?'); + my $nickserv_sth = $self->{dbh}->prepare('SELECT nickserv FROM Nickserv WHERE id = ?'); + my $gecos_sth = $self->{dbh}->prepare('SELECT gecos FROM Gecos WHERE id = ?'); + + my $csv = Text::CSV->new({binary => 1}); + + foreach my $id (keys %ids) { + $hostmask_sth->execute($id); + $rows = $hostmask_sth->fetchall_arrayref({}); + + foreach my $row (@$rows) { + $akas{$row->{hostmask}} = {hostmask => $row->{hostmask}, id => $id, alias => $ids{$id}->{id}, type => $ids{$id}->{type}, nickchange => $row->{nickchange}}; + $self->{pbot}->{logger}->log("[$id] Adding hostmask $row->{hostmask} -> $ids{$id}->{id} [type $ids{$id}->{type}]\n") if $debug; + } + + $nickserv_sth->execute($id); + $rows = $nickserv_sth->fetchall_arrayref({}); + + foreach my $row (@$rows) { + foreach my $aka (keys %akas) { + if ($akas{$aka}->{id} == $id) { + if (exists $akas{$aka}->{nickserv}) { $akas{$aka}->{nickserv} .= ",$row->{nickserv}"; } + else { $akas{$aka}->{nickserv} = $row->{nickserv}; } + } + } + } + + $gecos_sth->execute($id); + $rows = $gecos_sth->fetchall_arrayref({}); + + foreach my $row (@$rows) { + foreach my $aka (keys %akas) { + if ($akas{$aka}->{id} == $id) { + if (exists $akas{$aka}->{gecos}) { + $csv->parse($akas{$aka}->{gecos}); + my @gecos = $csv->fields; + push @gecos, $row->{gecos}; + $csv->combine(@gecos); + $akas{$aka}->{gecos} = $csv->string; + } else { + my @gecos = ($row->{gecos}); + $csv->combine(@gecos); + $akas{$aka}->{gecos} = $csv->string; + } + } + } + } + } + + return %akas; + } + + my $sth = $self->{dbh}->prepare('SELECT id, hostmask FROM Hostmasks WHERE nick = ? ORDER BY last_seen DESC'); + $sth->execute($nick); + my $rows = $sth->fetchall_arrayref({}); + + foreach my $row (@$rows) { + $hostmasks{$row->{hostmask}} = $row->{id}; + $ids{$row->{id}} = $row->{hostmask}; + $akas{$row->{hostmask}} = {hostmask => $row->{hostmask}, id => $row->{id}}; + $self->{pbot}->{logger}->log("Found matching nick [$nick] for hostmask $row->{hostmask} with id $row->{id}\n"); + } + + foreach my $hostmask (keys %hostmasks) { + my ($host) = $hostmask =~ /(\@.*)$/; + $sth = $self->{dbh}->prepare('SELECT id FROM Hostmasks WHERE host = ?'); + $sth->execute($host); + $rows = $sth->fetchall_arrayref({}); + + foreach my $row (@$rows) { + next if exists $ids{$row->{id}}; + $ids{$row->{id}} = $row->{id}; + + $sth = $self->{dbh}->prepare('SELECT hostmask FROM Hostmasks WHERE id == ?'); + $sth->execute($row->{id}); + my $rows = $sth->fetchall_arrayref({}); + + foreach my $nrow (@$rows) { + next if exists $akas{$nrow->{hostmask}}; + $akas{$nrow->{hostmask}} = {hostmask => $nrow->{hostmask}, id => $row->{id}}; + $self->{pbot}->{logger}->log("Adding matching host [$hostmask] and id [$row->{id}] AKA hostmask $nrow->{hostmask}\n"); + } + } + } + + my %nickservs; foreach my $id (keys %ids) { - next if $ids{$id}->{type} == $self->{alias_type}->{WEAK}; - next if exists $seen_id{$id}; - $seen_id{$id} = $id; + $sth = $self->{dbh}->prepare('SELECT nickserv FROM Nickserv WHERE id == ?'); + $sth->execute($id); + $rows = $sth->fetchall_arrayref({}); - $sth->execute($id); - my $rows = $sth->fetchall_arrayref({}); - - foreach my $row (@$rows) { - next if exists $ids{$row->{id}}; - #next if $row->{type} == $self->{alias_type}->{WEAK}; - $ids{$row->{id}} = { id => $id, type => $ids{$id}->{type} == $self->{alias_type}->{WEAK} ? $self->{alias_type}->{WEAK} : $row->{type} }; - $new_aliases++; - $self->{pbot}->{logger}->log("[$id] 2) Adding $row->{id} -> $id [type $row->{type}]\n") if $debug; - } - } - last if not $new_aliases; - } - - my $hostmask_sth = $self->{dbh}->prepare('SELECT hostmask, nickchange FROM Hostmasks WHERE id = ?'); - my $nickserv_sth = $self->{dbh}->prepare('SELECT nickserv FROM Nickserv WHERE id = ?'); - my $gecos_sth = $self->{dbh}->prepare('SELECT gecos FROM Gecos WHERE id = ?'); - - my $csv = Text::CSV->new({binary => 1}); - - foreach my $id (keys %ids) { - $hostmask_sth->execute($id); - $rows = $hostmask_sth->fetchall_arrayref({}); - - foreach my $row (@$rows) { - $akas{$row->{hostmask}} = { hostmask => $row->{hostmask}, id => $id, alias => $ids{$id}->{id}, type => $ids{$id}->{type}, nickchange => $row->{nickchange} }; - $self->{pbot}->{logger}->log("[$id] Adding hostmask $row->{hostmask} -> $ids{$id}->{id} [type $ids{$id}->{type}]\n") if $debug; + foreach my $row (@$rows) { $nickservs{$row->{nickserv}} = $id; } } - $nickserv_sth->execute($id); - $rows = $nickserv_sth->fetchall_arrayref({}); - - foreach my $row (@$rows) { - foreach my $aka (keys %akas) { - if ($akas{$aka}->{id} == $id) { - if (exists $akas{$aka}->{nickserv}) { - $akas{$aka}->{nickserv} .= ",$row->{nickserv}"; - } else { - $akas{$aka}->{nickserv} = $row->{nickserv}; - } + foreach my $nickserv (sort keys %nickservs) { + foreach my $aka (keys %akas) { + if ($akas{$aka}->{id} == $nickservs{$nickserv}) { + if (exists $akas{$aka}->{nickserv}) { $akas{$aka}->{nickserv} .= ",$nickserv"; } + else { $akas{$aka}->{nickserv} = $nickserv; } + } } - } - } - $gecos_sth->execute($id); - $rows = $gecos_sth->fetchall_arrayref({}); + $sth = $self->{dbh}->prepare('SELECT id FROM Nickserv WHERE nickserv == ?'); + $sth->execute($nickserv); + $rows = $sth->fetchall_arrayref({}); - foreach my $row (@$rows) { - foreach my $aka (keys %akas) { - if ($akas{$aka}->{id} == $id) { - if (exists $akas{$aka}->{gecos}) { - $csv->parse($akas{$aka}->{gecos}); - my @gecos = $csv->fields; - push @gecos, $row->{gecos}; - $csv->combine(@gecos); - $akas{$aka}->{gecos} = $csv->string; - } else { - my @gecos = ($row->{gecos}); - $csv->combine(@gecos); - $akas{$aka}->{gecos} = $csv->string; - } + foreach my $row (@$rows) { + next if exists $ids{$row->{id}}; + $ids{$row->{id}} = $row->{id}; + + $sth = $self->{dbh}->prepare('SELECT hostmask FROM Hostmasks WHERE id == ?'); + $sth->execute($row->{id}); + my $rows = $sth->fetchall_arrayref({}); + + foreach my $nrow (@$rows) { + if (exists $akas{$nrow->{hostmask}}) { + if (exists $akas{$nrow->{hostmask}}->{nickserv}) { $akas{$nrow->{hostmask}}->{nickserv} .= ",$nickserv"; } + else { $akas{$nrow->{hostmask}}->{nickserv} = $nickserv; } + } else { + $akas{$nrow->{hostmask}} = {hostmask => $nrow->{hostmask}, id => $row->{id}, nickserv => $nickserv}; + $self->{pbot}->{logger}->log("Adding matching nickserv [$nickserv] and id [$row->{id}] AKA hostmask $nrow->{hostmask}\n"); + } + } } - } } - } - return %akas; - } + foreach my $id (keys %ids) { + $sth = $self->{dbh}->prepare('SELECT hostmask FROM Hostmasks WHERE id == ?'); + $sth->execute($id); + $rows = $sth->fetchall_arrayref({}); - my $sth = $self->{dbh}->prepare('SELECT id, hostmask FROM Hostmasks WHERE nick = ? ORDER BY last_seen DESC'); - $sth->execute($nick); - my $rows = $sth->fetchall_arrayref({}); - - foreach my $row (@$rows) { - $hostmasks{$row->{hostmask}} = $row->{id}; - $ids{$row->{id}} = $row->{hostmask}; - $akas{$row->{hostmask}} = { hostmask => $row->{hostmask}, id => $row->{id} }; - $self->{pbot}->{logger}->log("Found matching nick [$nick] for hostmask $row->{hostmask} with id $row->{id}\n"); - } - - foreach my $hostmask (keys %hostmasks) { - my ($host) = $hostmask =~ /(\@.*)$/; - $sth = $self->{dbh}->prepare('SELECT id FROM Hostmasks WHERE host = ?'); - $sth->execute($host); - $rows = $sth->fetchall_arrayref({}); - - foreach my $row (@$rows) { - next if exists $ids{$row->{id}}; - $ids{$row->{id}} = $row->{id}; - - $sth = $self->{dbh}->prepare('SELECT hostmask FROM Hostmasks WHERE id == ?'); - $sth->execute($row->{id}); - my $rows = $sth->fetchall_arrayref({}); - - foreach my $nrow (@$rows) { - next if exists $akas{$nrow->{hostmask}}; - $akas{$nrow->{hostmask}} = { hostmask => $nrow->{hostmask}, id => $row->{id} }; - $self->{pbot}->{logger}->log("Adding matching host [$hostmask] and id [$row->{id}] AKA hostmask $nrow->{hostmask}\n"); - } - } - } - - my %nickservs; - foreach my $id (keys %ids) { - $sth = $self->{dbh}->prepare('SELECT nickserv FROM Nickserv WHERE id == ?'); - $sth->execute($id); - $rows = $sth->fetchall_arrayref({}); - - foreach my $row (@$rows) { - $nickservs{$row->{nickserv}} = $id; - } - } - - foreach my $nickserv (sort keys %nickservs) { - foreach my $aka (keys %akas) { - if ($akas{$aka}->{id} == $nickservs{$nickserv}) { - if (exists $akas{$aka}->{nickserv}) { - $akas{$aka}->{nickserv} .= ",$nickserv"; - } else { - $akas{$aka}->{nickserv} = $nickserv; - } - } - } - - $sth = $self->{dbh}->prepare('SELECT id FROM Nickserv WHERE nickserv == ?'); - $sth->execute($nickserv); - $rows = $sth->fetchall_arrayref({}); - - foreach my $row (@$rows) { - next if exists $ids{$row->{id}}; - $ids{$row->{id}} = $row->{id}; - - $sth = $self->{dbh}->prepare('SELECT hostmask FROM Hostmasks WHERE id == ?'); - $sth->execute($row->{id}); - my $rows = $sth->fetchall_arrayref({}); - - foreach my $nrow (@$rows) { - if (exists $akas{$nrow->{hostmask}}) { - if (exists $akas{$nrow->{hostmask}}->{nickserv}) { - $akas{$nrow->{hostmask}}->{nickserv} .= ",$nickserv"; - } else { - $akas{$nrow->{hostmask}}->{nickserv} = $nickserv; + foreach my $row (@$rows) { + next if exists $akas{$row->{hostmask}}; + $akas{$row->{hostmask}} = {hostmask => $row->{hostmask}, id => $id}; + $self->{pbot}->{logger}->log("Adding matching id [$id] AKA hostmask $row->{hostmask}\n"); } - } else { - $akas{$nrow->{hostmask}} = { hostmask => $nrow->{hostmask}, id => $row->{id}, nickserv => $nickserv }; - $self->{pbot}->{logger}->log("Adding matching nickserv [$nickserv] and id [$row->{id}] AKA hostmask $nrow->{hostmask}\n"); - } } - } - } - foreach my $id (keys %ids) { - $sth = $self->{dbh}->prepare('SELECT hostmask FROM Hostmasks WHERE id == ?'); - $sth->execute($id); - $rows = $sth->fetchall_arrayref({}); - - foreach my $row (@$rows) { - next if exists $akas{$row->{hostmask}}; - $akas{$row->{hostmask}} = { hostmask => $row->{hostmask}, id => $id }; - $self->{pbot}->{logger}->log("Adding matching id [$id] AKA hostmask $row->{hostmask}\n"); - } - } + return %akas; + }; + $self->{pbot}->{logger}->log("bad aka: $@") if $@; return %akas; - }; - - $self->{pbot}->{logger}->log("bad aka: $@") if $@; - return %akas; } sub get_ancestor_id { - my ($self, $id) = @_; + my ($self, $id) = @_; - $id = 0 if not defined $id; + $id = 0 if not defined $id; - my $ancestor = eval { - my $sth = $self->{dbh}->prepare('SELECT id FROM Aliases WHERE alias = ? ORDER BY id LIMIT 1'); - $sth->execute($id); - my $row = $sth->fetchrow_hashref(); - return defined $row ? $row->{id} : 0; - }; + my $ancestor = eval { + my $sth = $self->{dbh}->prepare('SELECT id FROM Aliases WHERE alias = ? ORDER BY id LIMIT 1'); + $sth->execute($id); + my $row = $sth->fetchrow_hashref(); + return defined $row ? $row->{id} : 0; + }; - $self->{pbot}->{logger}->log($@) if $@; + $self->{pbot}->{logger}->log($@) if $@; - return $id if not $ancestor; - return $ancestor < $id ? $ancestor : $id; + return $id if not $ancestor; + return $ancestor < $id ? $ancestor : $id; } # End of public API, the remaining are internal support routines for this module sub get_new_account_id { - my $self = shift; + my $self = shift; - my $id = eval { - my $sth = $self->{dbh}->prepare('SELECT id FROM Accounts ORDER BY id DESC LIMIT 1'); - $sth->execute(); - my $row = $sth->fetchrow_hashref(); - return $row->{id}; - }; + my $id = eval { + my $sth = $self->{dbh}->prepare('SELECT id FROM Accounts ORDER BY id DESC LIMIT 1'); + $sth->execute(); + my $row = $sth->fetchrow_hashref(); + return $row->{id}; + }; - $self->{pbot}->{logger}->log($@) if $@; - return ++$id; + $self->{pbot}->{logger}->log($@) if $@; + return ++$id; } sub get_message_account_id { - my ($self, $mask) = @_; + my ($self, $mask) = @_; - my $id = eval { - my $sth = $self->{dbh}->prepare('SELECT id FROM Hostmasks WHERE hostmask == ?'); - $sth->execute($mask); - my $row = $sth->fetchrow_hashref(); - return $row->{id}; - }; + my $id = eval { + my $sth = $self->{dbh}->prepare('SELECT id FROM Hostmasks WHERE hostmask == ?'); + $sth->execute($mask); + my $row = $sth->fetchrow_hashref(); + return $row->{id}; + }; - $self->{pbot}->{logger}->log($@) if $@; - #$self->{pbot}->{logger}->log("get_message_account_id: returning id [". (defined $id ? $id: 'undef') . "] for mask [$mask]\n"); - return $id; + $self->{pbot}->{logger}->log($@) if $@; + + #$self->{pbot}->{logger}->log("get_message_account_id: returning id [". (defined $id ? $id: 'undef') . "] for mask [$mask]\n"); + return $id; } sub commit_message_history { - my $self = shift; + my $self = shift; - return if not $self->{dbh}; + return if not $self->{dbh}; - if ($self->{new_entries} > 0) { - # $self->{pbot}->{logger}->log("Commiting $self->{new_entries} messages to SQLite\n"); - eval { - $self->{dbh}->commit(); - }; + if ($self->{new_entries} > 0) { - $self->{pbot}->{logger}->log("SQLite error $@ when committing $self->{new_entries} entries.\n") if $@; + # $self->{pbot}->{logger}->log("Commiting $self->{new_entries} messages to SQLite\n"); + eval { $self->{dbh}->commit(); }; - $self->{dbh}->begin_work(); - $self->{new_entries} = 0; - } + $self->{pbot}->{logger}->log("SQLite error $@ when committing $self->{new_entries} entries.\n") if $@; + + $self->{dbh}->begin_work(); + $self->{new_entries} = 0; + } } 1; diff --git a/PBot/Modules.pm b/PBot/Modules.pm index d45382fe..85f2d3ce 100644 --- a/PBot/Modules.pm +++ b/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 " 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 " 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 " 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 " 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; diff --git a/PBot/NickList.pm b/PBot/NickList.pm index af9b5b3f..d686a26c 100644 --- a/PBot/NickList.pm +++ b/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 [nick]" if not length $arguments; + my ($self, $from, $nick, $user, $host, $arguments) = @_; + my $nicklist; + return "Usage: nicklist [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; diff --git a/PBot/PBot.pm b/PBot/PBot.pm index fe8000d2..14e1a4a7 100644 --- a/PBot/PBot.pm +++ b/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 "; + my $usage = "Usage: list "; - 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 " if not length $arguments; - $self->{conn}->sl($arguments); - return ""; + my $self = shift; + my ($from, $nick, $user, $host, $arguments) = @_; + return "Usage: sl " 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 " if not defined $arguments; + return "Usage: export " 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; diff --git a/PBot/Plugins.pm b/PBot/Plugins.pm index 38ab43af..2ef8391d 100644 --- a/PBot/Plugins.pm +++ b/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 "; - } + if (not length $arguments) { return "Usage: replug "; } - 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 "; - } + if (not length $arguments) { return "Usage: plug "; } - 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 "; - } + if (not length $arguments) { return "Usage: unplug "; } - 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; diff --git a/PBot/ProcessManager.pm b/PBot/ProcessManager.pm index d9747f6d..521b23a6 100644 --- a/PBot/ProcessManager.pm +++ b/PBot/ProcessManager.pm @@ -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 "; - 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 "; + 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; diff --git a/PBot/Refresher.pm b/PBot/Refresher.pm index d73b2abf..0d1302a9 100644 --- a/PBot/Refresher.pm +++ b/PBot/Refresher.pm @@ -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; diff --git a/PBot/Registerable.pm b/PBot/Registerable.pm index 7e01bc9d..ac00e89c 100644 --- a/PBot/Registerable.pm +++ b/PBot/Registerable.pm @@ -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; diff --git a/PBot/Registry.pm b/PBot/Registry.pm index 7bcc1e66..4522a7cf 100644 --- a/PBot/Registry.pm +++ b/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; diff --git a/PBot/RegistryCommands.pm b/PBot/RegistryCommands.pm index 8ba490bc..fa80742e 100644 --- a/PBot/RegistryCommands.pm +++ b/PBot/RegistryCommands.pm @@ -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
. [value]"; + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $usage = "Usage: regset
. [value]"; - # support "
." syntax in addition to "
" - 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 "
." syntax in addition to "
" + 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
."; + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $usage = "Usage: regunset
."; - # support "
." syntax in addition to "
" - 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 "
." syntax in addition to "
" + 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
. [key [value]]"; + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $usage = "Usage: regsetmeta
. [key [value]]"; - # support "
." syntax in addition to "
" - 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 "
." syntax in addition to "
" + 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
. "; + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $usage = "Usage: regunsetmeta
. "; - # support "
." syntax in addition to "
" - 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 "
." syntax in addition to "
" + 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
."; + my $self = shift; + my ($from, $nick, $user, $host, $arguments, $stuff) = @_; + my $registry = $self->{pbot}->{registry}->{registry}; + my $usage = "Usage: regshow
."; - # support "
." syntax in addition to "
" - 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 "
." syntax in addition to "
" + 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: "; - } + if ($registry->get_data($section, $item, 'private')) { return "$section.$item: "; } - 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] "; + my $self = shift; + my ($from, $nick, $user, $host, $arguments) = @_; + my $registry = $self->{pbot}->{registry}->{registry}; + my $usage = "Usage: regfind [-showvalues] [-section section] "; - 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 = \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: "; } + 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 = \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: "; } 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
. s///"; } - if (not defined $section or not defined $item or not defined $changeto) { - return "Usage: regchange
. s///"; - } + $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; diff --git a/PBot/SQLiteLogger.pm b/PBot/SQLiteLogger.pm index c2d007ae..3021d017 100644 --- a/PBot/SQLiteLogger.pm +++ b/PBot/SQLiteLogger.pm @@ -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; diff --git a/PBot/SQLiteLoggerLayer.pm b/PBot/SQLiteLoggerLayer.pm index 9705fbca..73222d56 100644 --- a/PBot/SQLiteLoggerLayer.pm +++ b/PBot/SQLiteLoggerLayer.pm @@ -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; diff --git a/PBot/SelectHandler.pm b/PBot/SelectHandler.pm index 36957c3b..66ad9168 100644 --- a/PBot/SelectHandler.pm +++ b/PBot/SelectHandler.pm @@ -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; diff --git a/PBot/StdinReader.pm b/PBot/StdinReader.pm index 4a7b1847..1d0c9e35 100644 --- a/PBot/StdinReader.pm +++ b/PBot/StdinReader.pm @@ -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, "{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, "{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; diff --git a/PBot/Timer.pm b/PBot/Timer.pm index 1aee4dbd..b19e9d78 100644 --- a/PBot/Timer.pm +++ b/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; diff --git a/PBot/Users.pm b/PBot/Users.pm index ce24f912..752b6fe6 100644 --- a/PBot/Users.pm +++ b/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 [capabilities [password]]"; - } + if (not defined $name or not defined $channel or not defined $hostmask) { return "Usage: useradd [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 "; - } + if (not defined $channel or not defined $hostmask) { return "Usage: userdel "; } - 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] [key [value]]"; - } + if (not defined $hostmask) { return "Usage: userset [channel] [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 => ;/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 => ;/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] "; - } + if (not defined $hostmask) { return "Usage: userunset [channel] "; } - 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 [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 => ;/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 [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 => ;/m; + return $result; } 1; diff --git a/PBot/Utils/Indefinite.pm b/PBot/Utils/Indefinite.pm index 5a723f12..ea87f0da 100644 --- a/PBot/Utils/Indefinite.pm +++ b/PBot/Utils/Indefinite.pm @@ -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 diff --git a/PBot/Utils/LWPUserAgentCached.pm b/PBot/Utils/LWPUserAgentCached.pm index 21473281..599925b6 100644 --- a/PBot/Utils/LWPUserAgentCached.pm +++ b/PBot/Utils/LWPUserAgentCached.pm @@ -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; diff --git a/PBot/Utils/ParseDate.pm b/PBot/Utils/ParseDate.pm index 82f019f4..afa93e7b 100644 --- a/PBot/Utils/ParseDate.pm +++ b/PBot/Utils/ParseDate.pm @@ -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; diff --git a/PBot/Utils/SafeFilename.pm b/PBot/Utils/SafeFilename.pm index a85e4153..7d3f7d5e 100644 --- a/PBot/Utils/SafeFilename.pm +++ b/PBot/Utils/SafeFilename.pm @@ -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; diff --git a/PBot/Utils/ValidateString.pm b/PBot/Utils/ValidateString.pm index 7d7f7401..431cdb36 100644 --- a/PBot/Utils/ValidateString.pm +++ b/PBot/Utils/ValidateString.pm @@ -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; diff --git a/PBot/VERSION.pm b/PBot/VERSION.pm index 35369962..cfe35b6a 100644 --- a/PBot/VERSION.pm +++ b/PBot/VERSION.pm @@ -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; diff --git a/PBot/WebPaste.pm b/PBot/WebPaste.pm index 70004e7a..74722b18 100644 --- a/PBot/WebPaste.pm +++ b/PBot/WebPaste.pm @@ -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; diff --git a/Plugins/ActionTrigger.pm b/Plugins/ActionTrigger.pm index 66b17ea6..ff8f7f7f 100644 --- a/Plugins/ActionTrigger.pm +++ b/Plugins/ActionTrigger.pm @@ -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(<{dbh}->do(<{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 argument is required. Usage: actiontrigger add <#channel or global> "; + } elsif ($channel !~ m/^#/ and $channel ne 'global') { + return "Invalid channel $channel. Usage: actiontrigger add <#channel or global> "; + } + } + + 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 argument is required. Usage: actiontrigger add <#channel or global> "; + } else { + $result = "Usage: actiontrigger add "; + } + 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 argument is required. Usage: actiontrigger delete <#channel or global> "; + } + } + + 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 argument is required. Usage: from private message: actiontrigger delete "; + } else { + $result = "Usage: actiontrigger delete "; + } + 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> | actiontrigger delete <#channel or global> "; + } else { + $result = + "Usage: actiontrigger list [#channel or global] | actiontrigger add | actiontrigger delete "; + } } - } } - -# 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 argument is required. Usage: actiontrigger add <#channel or global> "; - } elsif ($channel !~ m/^#/ and $channel ne 'global') { - return "Invalid channel $channel. Usage: actiontrigger add <#channel or global> "; - } - } - - 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 argument is required. Usage: actiontrigger add <#channel or global> "; - } else { - $result = "Usage: actiontrigger add "; - } - 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 argument is required. Usage: actiontrigger delete <#channel or global> "; - } - } - - 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 argument is required. Usage: from private message: actiontrigger delete "; - } else { - $result = "Usage: actiontrigger delete "; - } - 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> | actiontrigger delete <#channel or global> "; - } else { - $result = "Usage: actiontrigger list [#channel or global] | actiontrigger add | actiontrigger delete "; - } - } - } - return $result; + return $result; } 1; diff --git a/Plugins/AntiAway.pm b/Plugins/AntiAway.pm index 4e8444b4..51c755dc 100644 --- a/Plugins/AntiAway.pm +++ b/Plugins/AntiAway.pm @@ -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; diff --git a/Plugins/AntiKickAutoRejoin.pm b/Plugins/AntiKickAutoRejoin.pm index 0c7ccccd..4b2b527d 100644 --- a/Plugins/AntiKickAutoRejoin.pm +++ b/Plugins/AntiKickAutoRejoin.pm @@ -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; diff --git a/Plugins/AntiNickSpam.pm b/Plugins/AntiNickSpam.pm index 8a7b94c6..2aa2e632 100644 --- a/Plugins/AntiNickSpam.pm +++ b/Plugins/AntiNickSpam.pm @@ -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; diff --git a/Plugins/AntiRepeat.pm b/Plugins/AntiRepeat.pm index 1ee95b0b..80c9bf38 100644 --- a/Plugins/AntiRepeat.pm +++ b/Plugins/AntiRepeat.pm @@ -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; diff --git a/Plugins/AntiTwitter.pm b/Plugins/AntiTwitter.pm index 1f1f133c..8711574b 100644 --- a/Plugins/AntiTwitter.pm +++ b/Plugins/AntiTwitter.pm @@ -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; diff --git a/Plugins/AutoRejoin.pm b/Plugins/AutoRejoin.pm index e2134b92..26f30cd0 100644 --- a/Plugins/AutoRejoin.pm +++ b/Plugins/AutoRejoin.pm @@ -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; diff --git a/Plugins/Battleship.pm b/Plugins/Battleship.pm index be8798cf..f1b5fb46 100644 --- a/Plugins/Battleship.pm +++ b/Plugins/Battleship.pm @@ -3,6 +3,7 @@ # file, You can obtain one at http://mozilla.org/MPL/2.0/. package Plugins::Battleship; + use parent 'Plugins::Plugin'; use warnings; use strict; @@ -10,1175 +11,1085 @@ use feature 'unicode_strings'; use utf8; use feature 'switch'; + no if $] >= 5.018, warnings => "experimental::smartmatch"; use Time::Duration qw/concise duration/; use Data::Dumper; -$Data::Dumper::Useqq = 1; +$Data::Dumper::Useqq = 1; $Data::Dumper::Sortkeys = 1; sub initialize { - my ($self, %conf) = @_; - $self->{pbot}->{commands}->register(sub { $self->battleship_cmd(@_) }, 'battleship', 0); + my ($self, %conf) = @_; + $self->{pbot}->{commands}->register(sub { $self->battleship_cmd(@_) }, 'battleship', 0); - $self->{pbot}->{timer}->register(sub { $self->battleship_timer }, 1, 'battleship timer'); + $self->{pbot}->{timer}->register(sub { $self->battleship_timer }, 1, 'battleship timer'); - $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.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->{channel} = $self->{pbot}->{registry}->get_value('battleship', 'channel') // '##battleship'; - $self->{debug} = $self->{pbot}->{registry}->get_value('battleship', 'debug') // 0; + $self->{channel} = $self->{pbot}->{registry}->get_value('battleship', 'channel') // '##battleship'; + $self->{debug} = $self->{pbot}->{registry}->get_value('battleship', 'debug') // 0; - $self->{player_one_vert} = '|'; - $self->{player_one_horiz} = '—'; - $self->{player_two_vert} = 'I'; - $self->{player_two_horiz} = '='; + $self->{player_one_vert} = '|'; + $self->{player_one_horiz} = '—'; + $self->{player_two_vert} = 'I'; + $self->{player_two_horiz} = '='; - $self->create_states; + $self->create_states; } sub unload { - my $self = shift; - $self->{pbot}->{commands}->unregister('battleship'); - $self->{pbot}->{timer}->unregister('battleship timer'); - $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->{pbot}->{commands}->unregister('battleship'); + $self->{pbot}->{timer}->unregister('battleship timer'); + $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 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 lc $channel ne $self->{channel}; - $self->player_left($nick, $user, $host); - return 0; + 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 lc $channel ne $self->{channel}; + $self->player_left($nick, $user, $host); + return 0; } sub on_departure { - my ($self, $event_type, $event) = @_; - my ($nick, $user, $host, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to); - my $type = uc $event->{event}->type; - return 0 if $type ne 'QUIT' and lc $channel ne $self->{channel}; - $self->player_left($nick, $user, $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); + my $type = uc $event->{event}->type; + return 0 if $type ne 'QUIT' and lc $channel ne $self->{channel}; + $self->player_left($nick, $user, $host); + return 0; } my %color = ( - white => "\x0300", - black => "\x0301", - blue => "\x0302", - green => "\x0303", - red => "\x0304", - maroon => "\x0305", - purple => "\x0306", - orange => "\x0307", - yellow => "\x0308", - lightgreen => "\x0309", - teal => "\x0310", - cyan => "\x0311", - lightblue => "\x0312", - magneta => "\x0313", - gray => "\x0314", - lightgray => "\x0315", + white => "\x0300", + black => "\x0301", + blue => "\x0302", + green => "\x0303", + red => "\x0304", + maroon => "\x0305", + purple => "\x0306", + orange => "\x0307", + yellow => "\x0308", + lightgreen => "\x0309", + teal => "\x0310", + cyan => "\x0311", + lightblue => "\x0312", + magneta => "\x0313", + gray => "\x0314", + lightgray => "\x0315", - bold => "\x02", - italics => "\x1D", - underline => "\x1F", - reverse => "\x16", + bold => "\x02", + italics => "\x1D", + underline => "\x1F", + reverse => "\x16", - reset => "\x0F", + reset => "\x0F", ); sub battleship_cmd { - my ($self, $from, $nick, $user, $host, $arguments) = @_; - $arguments =~ s/^\s+|\s+$//g; + my ($self, $from, $nick, $user, $host, $arguments) = @_; + $arguments =~ s/^\s+|\s+$//g; - my $usage = "Usage: battleship challenge|accept|bomb|board|score|quit|players|kick|abort; for more information about a command: battleship help "; + my $usage = "Usage: battleship challenge|accept|bomb|board|score|quit|players|kick|abort; for more information about a command: battleship help "; - my $command; - ($command, $arguments) = split / /, $arguments, 2; - $command = lc $command; + my $command; + ($command, $arguments) = split / /, $arguments, 2; + $command = lc $command; - my ($channel, $result); + my ($channel, $result); - given ($command) { - when ('help') { - given ($arguments) { + given ($command) { when ('help') { - return "Seriously?"; + given ($arguments) { + when ('help') { return "Seriously?"; } + + default { + if (length $arguments) { return "Battleship help is coming soon."; } + else { return "Usage: battleship help "; } + } + } } - default { - if (length $arguments) { - return "Battleship help is coming soon."; - } else { - return "Usage: battleship help "; - } - } - } - } + when ('leaderboard') { return "Coming soon."; } - when ('leaderboard') { - return "Coming soon."; - } + when ('challenge') { + if ($self->{current_state} ne 'nogame') { return "There is already a game of Battleship underway."; } - when ('challenge') { - if ($self->{current_state} ne 'nogame') { - return "There is already a game of Battleship underway."; - } + if (not length $arguments) { + $self->{current_state} = 'accept'; + $self->{state_data} = {players => [], counter => 0}; - if (not length $arguments) { - $self->{current_state} = 'accept'; - $self->{state_data} = { players => [], counter => 0 }; + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + my $player = {id => $id, name => $nick, missedinputs => 0}; + push @{$self->{state_data}->{players}}, $player; - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - my $player = { id => $id, name => $nick, missedinputs => 0 }; - push @{$self->{state_data}->{players}}, $player; + $player = {id => -1, name => undef, missedinputs => 0}; + push @{$self->{state_data}->{players}}, $player; + return "/msg $self->{channel} $nick has made an open challenge! Use `accept` to accept their challenge."; + } - $player = { id => -1, name => undef, missedinputs => 0 }; - push @{$self->{state_data}->{players}}, $player; - return "/msg $self->{channel} $nick has made an open challenge! Use `accept` to accept their challenge."; - } + my $challengee = $self->{pbot}->{nicklist}->is_present($self->{channel}, $arguments); - my $challengee = $self->{pbot}->{nicklist}->is_present($self->{channel}, $arguments); + if (not $challengee) { return "That nick is not present in this channel. Invite them to $self->{channel} and try again!"; } - if (not $challengee) { - return "That nick is not present in this channel. Invite them to $self->{channel} and try again!"; - } + $self->{current_state} = 'accept'; + $self->{state_data} = {players => [], counter => 0}; - $self->{current_state} = 'accept'; - $self->{state_data} = { players => [], counter => 0 }; + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + my $player = {id => $id, name => $nick, missedinputs => 0}; + push @{$self->{state_data}->{players}}, $player; - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - my $player = { id => $id, name => $nick, missedinputs => 0 }; - push @{$self->{state_data}->{players}}, $player; + ($id) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($challengee); + $player = {id => $id, name => $challengee, missedinputs => 0}; + push @{$self->{state_data}->{players}}, $player; - ($id) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($challengee); - $player = { id => $id, name => $challengee, missedinputs => 0 }; - push @{$self->{state_data}->{players}}, $player; - - return "/msg $self->{channel} $nick has challenged $challengee to Battleship! Use `accept` to accept their challenge."; - } - - when ('accept') { - if ($self->{current_state} ne 'accept') { - return "/msg $nick This is not the time to use `accept`."; - } - - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - my $player = $self->{state_data}->{players}->[1]; - - # open challenge - if ($player->{id} == -1) { - $player->{id} = $id; - $player->{name} = $nick; - } - - if ($player->{id} == $id) { - $player->{accepted} = 1; - return "/msg $self->{channel} $nick has accepted $self->{state_data}->{players}->[0]->{name}'s challenge!"; - } else { - return "/msg $nick You have not been challenged to a game of Battleship yet."; - } - } - - when ($_ eq 'decline' or $_ eq 'quit' or $_ eq 'forfeit' or $_ eq 'concede') { - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - my $removed = 0; - - for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { - if ($self->{state_data}->{players}->[$i]->{id} == $id) { - $self->{state_data}->{players}->[$i]->{removed} = 1; - $removed = 1; - } - } - - if ($removed) { - if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { - $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 + return "/msg $self->{channel} $nick has challenged $challengee to Battleship! Use `accept` to accept their challenge."; } - if (@{$self->{state_data}->{players}} == 2 and ($self->{state_data}->{players}->[1]->{id} == -1 || not $self->{state_data}->{players}->[1]->{accepted})) { - return "/msg $self->{channel} $nick declined the challenge."; - } else { - return "/msg $self->{channel} $nick has left the game!"; + when ('accept') { + if ($self->{current_state} ne 'accept') { return "/msg $nick This is not the time to use `accept`."; } + + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + my $player = $self->{state_data}->{players}->[1]; + + # open challenge + if ($player->{id} == -1) { + $player->{id} = $id; + $player->{name} = $nick; + } + + if ($player->{id} == $id) { + $player->{accepted} = 1; + return "/msg $self->{channel} $nick has accepted $self->{state_data}->{players}->[0]->{name}'s challenge!"; + } else { + return "/msg $nick You have not been challenged to a game of Battleship yet."; + } } - } else { - return "$nick: But you are not even playing the game."; - } - } - when ('abort') { - if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { - return "$nick: Sorry, only admins may abort the game."; - } + when ($_ eq 'decline' or $_ eq 'quit' or $_ eq 'forfeit' or $_ eq 'concede') { + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + my $removed = 0; - $self->{current_state} = 'gameover'; - return "/msg $self->{channel} $nick: The game has been aborted."; - } + for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { + if ($self->{state_data}->{players}->[$i]->{id} == $id) { + $self->{state_data}->{players}->[$i]->{removed} = 1; + $removed = 1; + } + } - when ('score') { - if (@{$self->{state_data}->{players}} == 2) { - $self->show_scoreboard; - return; - } else { - return "There is no game going on right now."; - } - } + if ($removed) { + if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 } - when ('players') { - if ($self->{current_state} eq 'accept') { - return "$self->{state_data}->{players}->[0]->{name} has challenged $self->{state_data}->{players}->[1]->{name}!"; - } elsif (@{$self->{state_data}->{players}} == 2) { - return "$self->{state_data}->{players}->[0]->{name} is in battle with $self->{state_data}->{players}->[1]->{name}!"; - } else { - return "There are no players playing right now. Start a game with `battleship challenge `!"; - } - } - - when ('kick') { - if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { - return "$nick: Sorry, only admins may kick people from the game."; - } - - if (not length $arguments) { - return "Usage: battleship kick "; - } - - my $removed = 0; - - for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { - if (lc $self->{state_data}->{players}->[$i]->{name} eq $arguments) { - $self->{state_data}->{players}->[$i]->{removed} = 1; - $removed = 1; + if (@{$self->{state_data}->{players}} == 2 and ($self->{state_data}->{players}->[1]->{id} == -1 || not $self->{state_data}->{players}->[1]->{accepted})) { + return "/msg $self->{channel} $nick declined the challenge."; + } else { + return "/msg $self->{channel} $nick has left the game!"; + } + } else { + return "$nick: But you are not even playing the game."; + } } - } - if ($removed) { - if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { - $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 + when ('abort') { + if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { return "$nick: Sorry, only admins may abort the game."; } + + $self->{current_state} = 'gameover'; + return "/msg $self->{channel} $nick: The game has been aborted."; } - return "/msg $self->{channel} $nick: $arguments has been kicked from the game."; - } else { - return "$nick: $arguments isn't even in the game."; - } + + when ('score') { + if (@{$self->{state_data}->{players}} == 2) { + $self->show_scoreboard; + return; + } else { + return "There is no game going on right now."; + } + } + + when ('players') { + if ($self->{current_state} eq 'accept') { return "$self->{state_data}->{players}->[0]->{name} has challenged $self->{state_data}->{players}->[1]->{name}!"; } + elsif (@{$self->{state_data}->{players}} == 2) { return "$self->{state_data}->{players}->[0]->{name} is in battle with $self->{state_data}->{players}->[1]->{name}!"; } + else { return "There are no players playing right now. Start a game with `battleship challenge `!"; } + } + + when ('kick') { + if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { return "$nick: Sorry, only admins may kick people from the game."; } + + if (not length $arguments) { return "Usage: battleship kick "; } + + my $removed = 0; + + for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { + if (lc $self->{state_data}->{players}->[$i]->{name} eq $arguments) { + $self->{state_data}->{players}->[$i]->{removed} = 1; + $removed = 1; + } + } + + if ($removed) { + if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 } + return "/msg $self->{channel} $nick: $arguments has been kicked from the game."; + } else { + return "$nick: $arguments isn't even in the game."; + } + } + + when ('bomb') { + if ($self->{debug}) { $self->{pbot}->{logger}->log("Battleship: bomb state: $self->{current_state}\n" . Dumper $self->{state_data}); } + + if ($self->{current_state} ne 'playermove' and $self->{current_state} ne 'checkplayer') { return "$nick: It's not time to do that now."; } + + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + my $player; + + if ($self->{state_data}->{players}->[0]->{id} == $id) { $player = 0; } + elsif ($self->{state_data}->{players}->[1]->{id} == $id) { $player = 1; } + else { return "You are not playing in this game."; } + + if (not length $arguments) { + if (delete $self->{state_data}->{players}->[$player]->{location}) { return "$nick: Attack location cleared."; } + else { return "$nick: Usage: bomb "; } + } + + if ($arguments !~ m/^[a-zA-Z][0-9]+$/) { return "$nick: Usage: battleship bomb ; must be in the form of A15, B3, C9, etc."; } + + $arguments = uc $arguments; + + my ($x, $y); + ($x) = $arguments =~ m/^(.)/; + ($y) = $arguments =~ m/^.(.*)/; + + $x = ord($x) - 65; + + if ($x < 0 || $x > $self->{N_Y} || $y < 0 || $y > $self->{N_X}) { return "$nick: Target out of range, try again."; } + + if ($self->{state_data}->{current_player} != $player) { + my $msg; + if (not exists $self->{state_data}->{players}->[$player]->{location}) { $msg = "$nick: You will attack $arguments when it is your turn."; } + else { $msg = "$nick: You will now attack $arguments instead of $self->{state_data}->{players}->[$player]->{location} when it is your turn."; } + $self->{state_data}->{players}->[$player]->{location} = $arguments; + return $msg; + } + + if ($self->{player}->[$player]->{done}) { return "$nick: You have already attacked this turn."; } + + if ($self->bomb($player, uc $arguments)) { + if ($self->{player}->[$player]->{won}) { + $self->{previous_state} = $self->{current_state}; + $self->{current_state} = 'checkplayer'; + $self->run_one_state; + } else { + $self->{player}->[$player]->{done} = 1; + $self->{player}->[!$player]->{done} = 0; + $self->{state_data}->{current_player} = !$player; + $self->{state_data}->{ticks} = 1; + $self->{state_data}->{first_tock} = 1; + $self->{state_data}->{counter} = 0; + } + } + } + + when ($_ eq 'specboard' or $_ eq 'board') { + if ($self->{current_state} eq 'nogame' or $self->{current_state} eq 'accept' or $self->{current_state} eq 'genboard' or $self->{current_state} eq 'gameover') { + return "$nick: There is no board to show right now."; + } + + if ($_ eq 'specboard') { + $self->show_battlefield(2); + return; + } + + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + for (my $i = 0; $i < 2; $i++) { + if ($self->{state_data}->{players}->[$i]->{id} == $id) { + $self->send_message($self->{channel}, "$nick surveys the battlefield!"); + $self->show_battlefield($i); + return; + } + } + $self->show_battlefield(2); + } + + when ('fullboard') { + if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { return "$nick: Sorry, only admins may see the full board."; } + + if ($self->{current_state} eq 'nogame' or $self->{current_state} eq 'accept' or $self->{current_state} eq 'genboard' or $self->{current_state} eq 'gameover') { + return "$nick: There is no board to show right now."; + } + + # show real board if admin is actually in the game ... no cheating! + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + for (my $i = 0; $i < 2; $i++) { + if ($self->{state_data}->{players}->[$i]->{id} == $id) { + $self->send_message($self->{channel}, "$nick surveys the battlefield!"); + $self->show_battlefield($i); + return; + } + } + $self->show_battlefield(4, $nick); + } + + default { return $usage; } } - when ('bomb') { - if ($self->{debug}) { - $self->{pbot}->{logger}->log("Battleship: bomb state: $self->{current_state}\n" . Dumper $self->{state_data}); - } - - if ($self->{current_state} ne 'playermove' and $self->{current_state} ne 'checkplayer') { - return "$nick: It's not time to do that now."; - } - - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - my $player; - - if ($self->{state_data}->{players}->[0]->{id} == $id) { - $player = 0; - } elsif ($self->{state_data}->{players}->[1]->{id} == $id) { - $player = 1; - } else { - return "You are not playing in this game."; - } - - if (not length $arguments) { - if (delete $self->{state_data}->{players}->[$player]->{location}) { - return "$nick: Attack location cleared."; - } else { - return "$nick: Usage: bomb "; - } - } - - if ($arguments !~ m/^[a-zA-Z][0-9]+$/) { - return "$nick: Usage: battleship bomb ; must be in the form of A15, B3, C9, etc."; - } - - $arguments = uc $arguments; - - my ($x, $y); - ($x) = $arguments =~ m/^(.)/; - ($y) = $arguments =~ m/^.(.*)/; - - $x = ord($x) - 65;; - - if ($x < 0 || $x > $self->{N_Y} || $y < 0 || $y > $self->{N_X}) { - return "$nick: Target out of range, try again."; - } - - - if ($self->{state_data}->{current_player} != $player) { - my $msg; - if (not exists $self->{state_data}->{players}->[$player]->{location}) { - $msg = "$nick: You will attack $arguments when it is your turn."; - } else { - $msg = "$nick: You will now attack $arguments instead of $self->{state_data}->{players}->[$player]->{location} when it is your turn."; - } - $self->{state_data}->{players}->[$player]->{location} = $arguments; - return $msg; - } - - if ($self->{player}->[$player]->{done}) { - return "$nick: You have already attacked this turn."; - } - - if ($self->bomb($player, uc $arguments)) { - if ($self->{player}->[$player]->{won}) { - $self->{previous_state} = $self->{current_state}; - $self->{current_state} = 'checkplayer'; - $self->run_one_state; - } else { - $self->{player}->[$player]->{done} = 1; - $self->{player}->[!$player]->{done} = 0; - $self->{state_data}->{current_player} = !$player; - $self->{state_data}->{ticks} = 1; - $self->{state_data}->{first_tock} = 1; - $self->{state_data}->{counter} = 0; - } - } - } - - when ($_ eq 'specboard' or $_ eq 'board') { - if ($self->{current_state} eq 'nogame' or $self->{current_state} eq 'accept' - or $self->{current_state} eq 'genboard' or $self->{current_state} eq 'gameover') { - return "$nick: There is no board to show right now."; - } - - if ($_ eq 'specboard') { - $self->show_battlefield(2); - return; - } - - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - for (my $i = 0; $i < 2; $i++) { - if ($self->{state_data}->{players}->[$i]->{id} == $id) { - $self->send_message($self->{channel}, "$nick surveys the battlefield!"); - $self->show_battlefield($i); - return; - } - } - $self->show_battlefield(2); - } - - when ('fullboard') { - if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { - return "$nick: Sorry, only admins may see the full board."; - } - - if ($self->{current_state} eq 'nogame' or $self->{current_state} eq 'accept' - or $self->{current_state} eq 'genboard' or $self->{current_state} eq 'gameover') { - return "$nick: There is no board to show right now."; - } - - # show real board if admin is actually in the game ... no cheating! - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - for (my $i = 0; $i < 2; $i++) { - if ($self->{state_data}->{players}->[$i]->{id} == $id) { - $self->send_message($self->{channel}, "$nick surveys the battlefield!"); - $self->show_battlefield($i); - return; - } - } - $self->show_battlefield(4, $nick); - } - - default { - return $usage; - } - } - - return $result; + return $result; } sub battleship_timer { - my $self = shift; - $self->run_one_state; + my $self = shift; + $self->run_one_state; } sub player_left { - my ($self, $nick, $user, $host) = @_; + my ($self, $nick, $user, $host) = @_; - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - my $removed = 0; - - for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { - if ($self->{state_data}->{players}->[$i]->{id} == $id) { - $self->{state_data}->{players}->[$i]->{removed} = 1; - $self->send_message($self->{channel}, "$nick has left the game!"); - $removed = 1; - } - } - - if ($removed) { - if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { - $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 - } - return "/msg $self->{channel} $nick has left the game!"; - } -} - -sub send_message { - my ($self, $to, $text, $delay) = @_; - $delay = 0 if not defined $delay; - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - my $message = { - nick => $botnick, user => 'battleship', host => 'localhost', command => 'battleship text', checkflood => 1, - message => $text - }; - $self->{pbot}->{interpreter}->add_message_to_output_queue($to, $message, $delay); -} - -sub run_one_state { - my $self = shift; - - # check for naughty or missing players - if ($self->{current_state} =~ /(?:move|accept)/) { + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); my $removed = 0; + for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { - if ($self->{state_data}->{players}->[$i]->{missedinputs} >= 3) { - $self->send_message($self->{channel}, "$color{red}$self->{state_data}->{players}->[$i]->{name} has missed too many prompts and has been ejected from the game!$color{reset}"); - $self->{state_data}->{players}->[$i]->{removed} = 1; - $removed = 1; - } + if ($self->{state_data}->{players}->[$i]->{id} == $id) { + $self->{state_data}->{players}->[$i]->{removed} = 1; + $self->send_message($self->{channel}, "$nick has left the game!"); + $removed = 1; + } } if ($removed) { - if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { - $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 - } + if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 } + return "/msg $self->{channel} $nick has left the game!"; + } +} + +sub send_message { + my ($self, $to, $text, $delay) = @_; + $delay = 0 if not defined $delay; + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + my $message = { + nick => $botnick, user => 'battleship', host => 'localhost', command => 'battleship text', checkflood => 1, + message => $text + }; + $self->{pbot}->{interpreter}->add_message_to_output_queue($to, $message, $delay); +} + +sub run_one_state { + my $self = shift; + + # check for naughty or missing players + if ($self->{current_state} =~ /(?:move|accept)/) { + my $removed = 0; + for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { + if ($self->{state_data}->{players}->[$i]->{missedinputs} >= 3) { + $self->send_message( + $self->{channel}, + "$color{red}$self->{state_data}->{players}->[$i]->{name} has missed too many prompts and has been ejected from the game!$color{reset}" + ); + $self->{state_data}->{players}->[$i]->{removed} = 1; + $removed = 1; + } + } + + if ($removed) { + if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 } + } + + if ($self->{state_data}->{players}->[0]->{removed} or $self->{state_data}->{players}->[1]->{removed}) { $self->{current_state} = 'gameover'; } } - if ($self->{state_data}->{players}->[0]->{removed} or $self->{state_data}->{players}->[1]->{removed}) { - $self->{current_state} = 'gameover'; - } - } + my $state_data = $self->{state_data}; - my $state_data = $self->{state_data}; - - # this shouldn't happen - if (not defined $self->{current_state}) { - $self->{pbot}->{logger}->log("Battleship state broke.\n"); - $self->{current_state} = 'nogame'; - return; - } - - # transistioned to a brand new state; prepare first tock - if ($self->{previous_state} ne $self->{current_state}) { - $state_data->{newstate} = 1; - $state_data->{ticks} = 1; - - if (exists $state_data->{tick_drift}) { - $state_data->{ticks} += $state_data->{tick_drift}; - delete $state_data->{tick_drift}; + # this shouldn't happen + if (not defined $self->{current_state}) { + $self->{pbot}->{logger}->log("Battleship state broke.\n"); + $self->{current_state} = 'nogame'; + return; } - $state_data->{first_tock} = 1; - $state_data->{counter} = 0; - } else { - $state_data->{newstate} = 0; - } + # transistioned to a brand new state; prepare first tock + if ($self->{previous_state} ne $self->{current_state}) { + $state_data->{newstate} = 1; + $state_data->{ticks} = 1; - # dump new state data for logging/debugging - if ($self->{debug} and $state_data->{newstate}) { - $self->{pbot}->{logger}->log("Battleship: New state: $self->{current_state}\n" . Dumper $state_data); - } + if (exists $state_data->{tick_drift}) { + $state_data->{ticks} += $state_data->{tick_drift}; + delete $state_data->{tick_drift}; + } - # run one state/tick - $state_data = $self->{states}{$self->{current_state}}{sub}($state_data); + $state_data->{first_tock} = 1; + $state_data->{counter} = 0; + } else { + $state_data->{newstate} = 0; + } - if ($state_data->{tocked}) { - delete $state_data->{tocked}; - delete $state_data->{first_tock}; - $state_data->{ticks} = 0; - } + # dump new state data for logging/debugging + if ($self->{debug} and $state_data->{newstate}) { $self->{pbot}->{logger}->log("Battleship: New state: $self->{current_state}\n" . Dumper $state_data); } - # transform to next state - $state_data->{previous_result} = $state_data->{result}; - $self->{previous_state} = $self->{current_state}; - $self->{current_state} = $self->{states}{$self->{current_state}}{trans}{$state_data->{result}}; - $self->{state_data} = $state_data; + # run one state/tick + $state_data = $self->{states}{$self->{current_state}}{sub}($state_data); - # next tick - $self->{state_data}->{ticks}++; + if ($state_data->{tocked}) { + delete $state_data->{tocked}; + delete $state_data->{first_tock}; + $state_data->{ticks} = 0; + } + + # transform to next state + $state_data->{previous_result} = $state_data->{result}; + $self->{previous_state} = $self->{current_state}; + $self->{current_state} = $self->{states}{$self->{current_state}}{trans}{$state_data->{result}}; + $self->{state_data} = $state_data; + + # next tick + $self->{state_data}->{ticks}++; } sub create_states { - my $self = shift; + my $self = shift; - $self->{pbot}->{logger}->log("Battleship: Creating game state machine\n"); + $self->{pbot}->{logger}->log("Battleship: Creating game state machine\n"); - $self->{previous_state} = ''; - $self->{current_state} = 'nogame'; - $self->{state_data} = { players => [], ticks => 0, newstate => 1 }; + $self->{previous_state} = ''; + $self->{current_state} = 'nogame'; + $self->{state_data} = {players => [], ticks => 0, newstate => 1}; - $self->{state_data}->{current_player} = 0; + $self->{state_data}->{current_player} = 0; - $self->{states}{'nogame'}{sub} = sub { $self->nogame(@_) }; - $self->{states}{'nogame'}{trans}{challenge} = 'accept'; - $self->{states}{'nogame'}{trans}{nogame} = 'nogame'; + $self->{states}{'nogame'}{sub} = sub { $self->nogame(@_) }; + $self->{states}{'nogame'}{trans}{challenge} = 'accept'; + $self->{states}{'nogame'}{trans}{nogame} = 'nogame'; - $self->{states}{'accept'}{sub} = sub { $self->accept(@_) }; - $self->{states}{'accept'}{trans}{stop} = 'nogame'; - $self->{states}{'accept'}{trans}{wait} = 'accept'; - $self->{states}{'accept'}{trans}{accept} = 'genboard'; + $self->{states}{'accept'}{sub} = sub { $self->accept(@_) }; + $self->{states}{'accept'}{trans}{stop} = 'nogame'; + $self->{states}{'accept'}{trans}{wait} = 'accept'; + $self->{states}{'accept'}{trans}{accept} = 'genboard'; - $self->{states}{'genboard'}{sub} = sub { $self->genboard(@_) }; - $self->{states}{'genboard'}{trans}{next} = 'showboard'; + $self->{states}{'genboard'}{sub} = sub { $self->genboard(@_) }; + $self->{states}{'genboard'}{trans}{next} = 'showboard'; - $self->{states}{'showboard'}{sub} = sub { $self->showboard(@_) }; - $self->{states}{'showboard'}{trans}{next} = 'playermove'; + $self->{states}{'showboard'}{sub} = sub { $self->showboard(@_) }; + $self->{states}{'showboard'}{trans}{next} = 'playermove'; - $self->{states}{'playermove'}{sub} = sub { $self->playermove(@_) }; - $self->{states}{'playermove'}{trans}{wait} = 'playermove'; - $self->{states}{'playermove'}{trans}{next} = 'checkplayer'; + $self->{states}{'playermove'}{sub} = sub { $self->playermove(@_) }; + $self->{states}{'playermove'}{trans}{wait} = 'playermove'; + $self->{states}{'playermove'}{trans}{next} = 'checkplayer'; - $self->{states}{'checkplayer'}{sub} = sub { $self->checkplayer(@_) }; - $self->{states}{'checkplayer'}{trans}{sunk} = 'gameover'; - $self->{states}{'checkplayer'}{trans}{next} = 'playermove'; + $self->{states}{'checkplayer'}{sub} = sub { $self->checkplayer(@_) }; + $self->{states}{'checkplayer'}{trans}{sunk} = 'gameover'; + $self->{states}{'checkplayer'}{trans}{next} = 'playermove'; - $self->{states}{'gameover'}{sub} = sub { $self->gameover(@_) }; - $self->{states}{'gameover'}{trans}{wait} = 'gameover'; - $self->{states}{'gameover'}{trans}{next} = 'nogame'; + $self->{states}{'gameover'}{sub} = sub { $self->gameover(@_) }; + $self->{states}{'gameover'}{trans}{wait} = 'gameover'; + $self->{states}{'gameover'}{trans}{next} = 'nogame'; } # battleship stuff sub init_game { - my ($self, $nick1, $nick2) = @_; + my ($self, $nick1, $nick2) = @_; - $self->{N_X} = 15; - $self->{N_Y} = 8; - $self->{SHIPS} = 6; + $self->{N_X} = 15; + $self->{N_Y} = 8; + $self->{SHIPS} = 6; - for (my $x = 0; $x < $self->{SHIPS}; $x++) { - $self->{ship_length}->[$x] = 0; - } + for (my $x = 0; $x < $self->{SHIPS}; $x++) { $self->{ship_length}->[$x] = 0; } - $self->{board} = []; + $self->{board} = []; - $self->{player} = [ - { bombs => 0, hit => 0, miss => 0, sunk => 0, nick => $nick1, done => 0 }, - { bombs => 0, hit => 0, miss => 0, sunk => 0, nick => $nick2, done => 0 } - ]; + $self->{player} = [ + {bombs => 0, hit => 0, miss => 0, sunk => 0, nick => $nick1, done => 0}, + {bombs => 0, hit => 0, miss => 0, sunk => 0, nick => $nick2, done => 0} + ]; - $self->{turn} = 0; - $self->{horiz} = 0; + $self->{turn} = 0; + $self->{horiz} = 0; - $self->generate_battlefield; + $self->generate_battlefield; } sub count_ship_sections { - my ($self, $player) = @_; - my ($x, $y, $sections); + my ($self, $player) = @_; + my ($x, $y, $sections); - $sections = 0; + $sections = 0; - for ($x = 0; $x < $self->{N_Y}; $x++) { - for ($y = 0; $y < $self->{N_X}; $y++) { - if ($player == 0) { - if ($self->{board}->[$x][$y] eq $self->{player_two_vert} || $self->{board}->[$x][$y] eq $self->{player_two_horiz}) { - $sections++; + for ($x = 0; $x < $self->{N_Y}; $x++) { + for ($y = 0; $y < $self->{N_X}; $y++) { + if ($player == 0) { + if ($self->{board}->[$x][$y] eq $self->{player_two_vert} || $self->{board}->[$x][$y] eq $self->{player_two_horiz}) { $sections++; } + } else { + if ($self->{board}->[$x][$y] eq $self->{player_one_vert} || $self->{board}->[$x][$y] eq $self->{player_one_horiz}) { $sections++; } + } } - } else { - if ($self->{board}->[$x][$y] eq $self->{player_one_vert} || $self->{board}->[$x][$y] eq $self->{player_one_horiz}) { - $sections++; - } - } } - } - return $sections; + return $sections; } sub check_ship { - my ($self, $x, $y, $o, $d, $l) = @_; - my ($xd, $yd, $i); + my ($self, $x, $y, $o, $d, $l) = @_; + my ($xd, $yd, $i); - if (!$o) { - if (!$d) { - $yd = -1; - if ($y - $l < 0) { return 0; } + if (!$o) { + if (!$d) { + $yd = -1; + if ($y - $l < 0) { return 0; } + } else { + $yd = 1; + if ($y + $l >= $self->{N_X}) { return 0; } + } + $xd = 0; } else { - $yd = 1; - if ($y + $l >= $self->{N_X}) { return 0; } + if (!$d) { + $xd = -1; + if ($x - $l < 0) { return 0; } + } else { + $xd = 1; + if ($x + $l >= $self->{N_Y}) { return 0; } + } + $yd = 0; } - $xd = 0; - } else { - if (!$d) { - $xd = -1; - if ($x - $l < 0) { return 0; } - } else { - $xd = 1; - if ($x + $l >= $self->{N_Y}) { return 0; } - } - $yd = 0; - } - for (my $i = 0; $i < $l; $i++) { - if ($self->{board}->[$x += $o ? $xd : 0][$y += $o ? 0 : $yd] ne '~') { - return 0; + for (my $i = 0; $i < $l; $i++) { + if ($self->{board}->[$x += $o ? $xd : 0][$y += $o ? 0 : $yd] ne '~') { return 0; } } - } - return 1; + return 1; } sub number { - my ($self, $lower, $upper) = @_; - return int(rand($upper - $lower)) + $lower; + my ($self, $lower, $upper) = @_; + return int(rand($upper - $lower)) + $lower; } sub generate_ship { - my ($self, $player, $ship) = @_; - my ($x, $y, $o, $d, $i, $l); - my ($yd, $xd) = (0, 0); + my ($self, $player, $ship) = @_; + my ($x, $y, $o, $d, $i, $l); + my ($yd, $xd) = (0, 0); - my $fail = 0; - while (1) { - $x = $self->number(0, $self->{N_Y}); - $y = $self->number(0, $self->{N_X}); + my $fail = 0; + while (1) { + $x = $self->number(0, $self->{N_Y}); + $y = $self->number(0, $self->{N_X}); - $o = $self->number(1, 10) < 6; - $d = $self->number(1, 10) < 6; + $o = $self->number(1, 10) < 6; + $d = $self->number(1, 10) < 6; - if (not $self->{ship_length}->[$ship]) { - $l = $self->number(3, 6); - } else { - $l = $self->{ship_length}->[$ship]; - } + if (not $self->{ship_length}->[$ship]) { $l = $self->number(3, 6); } + else { $l = $self->{ship_length}->[$ship]; } - $self->{pbot}->{logger}->log("generate ships player $player: ship $ship x,y: $x,$y o,d: $o,$d length: $l\n"); + $self->{pbot}->{logger}->log("generate ships player $player: ship $ship x,y: $x,$y o,d: $o,$d length: $l\n"); - if ($self->check_ship($x, $y, $o, $d, $l)) { - if (!$o) { - if ($self->{horiz} < 2) { next; } - if (!$d) { - $yd = -1; - } else { - $yd = 1; + if ($self->check_ship($x, $y, $o, $d, $l)) { + if (!$o) { + if ($self->{horiz} < 2) { next; } + if (!$d) { $yd = -1; } + else { $yd = 1; } + $xd = 0; + } else { + $self->{horiz}++; + if (!$d) { $xd = -1; } + else { $xd = 1; } + $yd = 0; + } + + for (my $i = 0; $i < $l; $i++) { + $self->{board}->[$x += $o ? $xd : 0][$y += $o ? 0 : $yd] = + $player ? ($o ? $self->{player_two_vert} : $self->{player_two_horiz}) : ($o ? $self->{player_one_vert} : $self->{player_one_horiz}); + } + + $self->{ship_length}->[$ship] = $l; + return 1; } - $xd = 0; - } else { - $self->{horiz}++; - if (!$d) { - $xd = -1; - } else { - $xd = 1; + + if (++$fail >= 5000) { + $self->{pbot}->{logger}->log("Failed to generate ship\n"); + $self->send_message($self->{channel}, "Failed to place a ship. I cannot continue. Game over."); + $self->{current_state} = 'nogame'; + return 0; } - $yd = 0; - } - - for (my $i = 0; $i < $l; $i++) { - $self->{board}->[$x += $o ? $xd : 0][$y += $o ? 0 : $yd] = $player ? ($o ? $self->{player_two_vert} : $self->{player_two_horiz}) : ($o ? $self->{player_one_vert} : $self->{player_one_horiz}); - } - - $self->{ship_length}->[$ship] = $l; - return 1; } - - if (++$fail >= 5000) { - $self->{pbot}->{logger}->log("Failed to generate ship\n"); - $self->send_message($self->{channel}, "Failed to place a ship. I cannot continue. Game over."); - $self->{current_state} = 'nogame'; - return 0; - } - } } sub generate_battlefield { - my ($self) = @_; - my ($x, $y); + my ($self) = @_; + my ($x, $y); - for ($y = 0; $y < $self->{N_Y}; $y++) { - for ($x = 0; $x < $self->{N_X}; $x++) { - $self->{board}->[$y][$x] = '~'; + for ($y = 0; $y < $self->{N_Y}; $y++) { + for ($x = 0; $x < $self->{N_X}; $x++) { $self->{board}->[$y][$x] = '~'; } } - } - for ($x = 0; $x < $self->{SHIPS}; $x++) { - if (!$self->generate_ship(0, $x) || !$self->generate_ship(1, $x)) { - return 0; + for ($x = 0; $x < $self->{SHIPS}; $x++) { + if (!$self->generate_ship(0, $x) || !$self->generate_ship(1, $x)) { return 0; } } - } - return 1; + return 1; } sub check_sunk { - my ($self, $x, $y, $player) = @_; - my ($i, $target); + my ($self, $x, $y, $player) = @_; + my ($i, $target); - $target = $self->{board}->[$x][$y]; + $target = $self->{board}->[$x][$y]; - given ($target) { - when ($_ eq $self->{player_two_vert} or $_ eq $self->{player_one_vert}) { - for ($i = $x + 1; $i < $self->{N_Y}; $i++) { - if (($self->{board}->[$i][$y] eq $self->{player_one_vert} && $player) || ($self->{board}->[$i][$y] eq $self->{player_two_vert} && !$player)) { - return 0; + given ($target) { + when ($_ eq $self->{player_two_vert} or $_ eq $self->{player_one_vert}) { + for ($i = $x + 1; $i < $self->{N_Y}; $i++) { + if (($self->{board}->[$i][$y] eq $self->{player_one_vert} && $player) || ($self->{board}->[$i][$y] eq $self->{player_two_vert} && !$player)) { return 0; } + + if ($self->{board}->[$i][$y] eq '~' || $self->{board}->[$i][$y] eq '*' || $self->{board}->[$i][$y] eq 'o') { last; } + } + + for ($i = $x - 1; $i >= 0; $i--) { + if (($self->{board}->[$i][$y] eq $self->{player_one_vert} && $player) || ($self->{board}->[$i][$y] eq $self->{player_two_vert} && !$player)) { return 0; } + + if ($self->{board}->[$i][$y] eq '~' || $self->{board}->[$i][$y] eq '*' || $self->{board}->[$i][$y] eq 'o') { last; } + } + + return 1; } - if ($self->{board}->[$i][$y] eq '~' || $self->{board}->[$i][$y] eq '*' || $self->{board}->[$i][$y] eq 'o') { - last; - } - } + when ($_ eq $self->{player_one_horiz} or $_ eq $self->{player_two_horiz}) { + for ($i = $y + 1; $i < $self->{N_X}; $i++) { + if (($self->{board}->[$x][$i] eq $self->{player_one_horiz} && $player) || ($self->{board}->[$x][$i] eq $self->{player_two_horiz} && !$player)) { return 0; } - for ($i = $x - 1; $i >= 0; $i--) { - if (($self->{board}->[$i][$y] eq $self->{player_one_vert} && $player) || ($self->{board}->[$i][$y] eq $self->{player_two_vert} && !$player)) { - return 0; - } + if ($self->{board}->[$x][$i] eq '~' || $self->{board}->[$x][$i] eq '*' || $self->{board}->[$x][$i] eq 'o') { last; } + } - if ($self->{board}->[$i][$y] eq '~' || $self->{board}->[$i][$y] eq '*' || $self->{board}->[$i][$y] eq 'o') { - last; - } - } + for ($i = $y - 1; $i >= 0; $i--) { + if (($self->{board}->[$x][$i] eq $self->{player_one_horiz} && $player) || ($self->{board}->[$x][$i] eq $self->{player_two_horiz} && !$player)) { return 0; } - return 1; + if ($self->{board}->[$x][$i] eq '~' || $self->{board}->[$x][$i] eq '*' || $self->{board}->[$x][$i] eq 'o') { last; } + } + + return 1; + } } - - when ($_ eq $self->{player_one_horiz} or $_ eq $self->{player_two_horiz}) { - for ($i = $y + 1; $i < $self->{N_X}; $i++) { - if (($self->{board}->[$x][$i] eq $self->{player_one_horiz} && $player) || ($self->{board}->[$x][$i] eq $self->{player_two_horiz} && !$player)) { - return 0; - } - - if ($self->{board}->[$x][$i] eq '~' || $self->{board}->[$x][$i] eq '*' || $self->{board}->[$x][$i] eq 'o') { - last; - } - } - - for ($i = $y - 1; $i >= 0; $i--) { - if (($self->{board}->[$x][$i] eq $self->{player_one_horiz} && $player) || ($self->{board}->[$x][$i] eq $self->{player_two_horiz} && !$player)) { - return 0; - } - - if ($self->{board}->[$x][$i] eq '~' || $self->{board}->[$x][$i] eq '*' || $self->{board}->[$x][$i] eq 'o') { - last; - } - } - - return 1; - } - } } sub bomb { - my ($self, $player, $location) = @_; - my ($x, $y, $hit, $sections, $sunk) = (0, 0, 0, 0, 0); + my ($self, $player, $location) = @_; + my ($x, $y, $hit, $sections, $sunk) = (0, 0, 0, 0, 0); - $location = uc $location; + $location = uc $location; - ($x) = $location =~ m/^(.)/; - ($y) = $location =~ m/^.(.*)/; + ($x) = $location =~ m/^(.)/; + ($y) = $location =~ m/^.(.*)/; - $x = ord($x) - 65;; + $x = ord($x) - 65; - $self->{pbot}->{logger}->log("bomb player $player $x,$y $self->{board}->[$x][$y]\n"); + $self->{pbot}->{logger}->log("bomb player $player $x,$y $self->{board}->[$x][$y]\n"); - if ($x < 0 || $x > $self->{N_Y} || $y < 0 || $y > $self->{N_X}) { - $self->send_message($self->{channel}, "Target out of range, try again."); - return 0; - } - - $y--; - - if (!$player) { - if ($self->{board}->[$x][$y] eq $self->{player_two_vert} || $self->{board}->[$x][$y] eq $self->{player_two_horiz}) { - $hit = 1; + if ($x < 0 || $x > $self->{N_Y} || $y < 0 || $y > $self->{N_X}) { + $self->send_message($self->{channel}, "Target out of range, try again."); + return 0; } - } else { - if ($self->{board}->[$x][$y] eq $self->{player_one_vert} || $self->{board}->[$x][$y] eq $self->{player_one_horiz}) { - $hit = 1; - } - } - $sunk = $self->check_sunk($x, $y, $player); + $y--; - if ($hit) { if (!$player) { - $self->{board}->[$x][$y] = '1'; + if ($self->{board}->[$x][$y] eq $self->{player_two_vert} || $self->{board}->[$x][$y] eq $self->{player_two_horiz}) { $hit = 1; } } else { - $self->{board}->[$x][$y] = '2'; + if ($self->{board}->[$x][$y] eq $self->{player_one_vert} || $self->{board}->[$x][$y] eq $self->{player_one_horiz}) { $hit = 1; } } - $self->{player}->[$player]->{hit}++; - } else { - if ($self->{board}->[$x][$y] eq '~') { - if (!$player) { - $self->{board}->[$x][$y] = '*'; - } else { - $self->{board}->[$x][$y] = 'o'; - } - $self->{player}->[$player]->{miss}++; + + $sunk = $self->check_sunk($x, $y, $player); + + if ($hit) { + if (!$player) { $self->{board}->[$x][$y] = '1'; } + else { $self->{board}->[$x][$y] = '2'; } + $self->{player}->[$player]->{hit}++; + } else { + if ($self->{board}->[$x][$y] eq '~') { + if (!$player) { $self->{board}->[$x][$y] = '*'; } + else { $self->{board}->[$x][$y] = 'o'; } + $self->{player}->[$player]->{miss}++; + } } - } - my $nick1 = $self->{player}->[$player]->{nick}; - my $nick2 = $self->{player}->[$player ? 0 : 1]->{nick}; + my $nick1 = $self->{player}->[$player]->{nick}; + my $nick2 = $self->{player}->[$player ? 0 : 1]->{nick}; - my @attacks = ("launches torpedoes at", "launches nukes at", "fires cannons at", "fires torpedoes at", "fires nukes at", - "launches tomahawk missiles at", "fires a gatling gun at", "launches ballistic missiles at"); + my @attacks = ( + "launches torpedoes at", "launches nukes at", "fires cannons at", "fires torpedoes at", "fires nukes at", + "launches tomahawk missiles at", "fires a gatling gun at", "launches ballistic missiles at" + ); - my $attacked = $attacks[rand @attacks]; - if ($hit) { - $self->send_message($self->{channel}, "$nick1 $attacked $nick2 at $location! $color{red}--- HIT! --- $color{reset}"); - $self->{player}->[$player]->{destroyed}++; + my $attacked = $attacks[rand @attacks]; + if ($hit) { + $self->send_message($self->{channel}, "$nick1 $attacked $nick2 at $location! $color{red}--- HIT! --- $color{reset}"); + $self->{player}->[$player]->{destroyed}++; - if ($sunk) { - $self->{player}->[$player]->{sunk}++; - my $remaining = $self->count_ship_sections($player); - $self->send_message($self->{channel}, "$color{red}$nick1 has sunk ${nick2}'s ship! $remaining ship section" . ($remaining != 1 ? 's' : '') . " remaining!$color{reset}"); + if ($sunk) { + $self->{player}->[$player]->{sunk}++; + my $remaining = $self->count_ship_sections($player); + $self->send_message($self->{channel}, "$color{red}$nick1 has sunk ${nick2}'s ship! $remaining ship section" . ($remaining != 1 ? 's' : '') . " remaining!$color{reset}"); - if ($remaining == 0) { - $self->send_message($self->{channel}, "$nick1 has WON the game of Battleship!"); - $self->{player}->[$player]->{won} = 1; - } + if ($remaining == 0) { + $self->send_message($self->{channel}, "$nick1 has WON the game of Battleship!"); + $self->{player}->[$player]->{won} = 1; + } + } + } else { + $self->send_message($self->{channel}, "$nick1 $attacked $nick2 at $location! --- miss ---"); } - } else { - $self->send_message($self->{channel}, "$nick1 $attacked $nick2 at $location! --- miss ---"); - } - $self->{player}->[$player]->{bombs}++; - return 1; + $self->{player}->[$player]->{bombs}++; + return 1; } sub show_scoreboard { - my ($self) = @_; - my $buf; - my $p1sections = $self->count_ship_sections(1); - my $p2sections = $self->count_ship_sections(0); + my ($self) = @_; - my $p1win = ""; - my $p2win = ""; + my $buf; + my $p1sections = $self->count_ship_sections(1); + my $p2sections = $self->count_ship_sections(0); - if ($p1sections > $p2sections) { - $p1win = "$color{bold}$color{lightgreen} * "; - $p2win = "$color{red} "; - } elsif ($p1sections < $p2sections) { - $p1win = "$color{red} "; - $p2win = "$color{bold}$color{lightgreen} * "; - } + my $p1win = ""; + my $p2win = ""; - my $length_a = length $self->{player}->[0]->{nick}; - my $length_b = length $self->{player}->[1]->{nick}; - my $longest = $length_a > $length_b ? $length_a : $length_b; + if ($p1sections > $p2sections) { + $p1win = "$color{bold}$color{lightgreen} * "; + $p2win = "$color{red} "; + } elsif ($p1sections < $p2sections) { + $p1win = "$color{red} "; + $p2win = "$color{bold}$color{lightgreen} * "; + } - my $bombslen = ($self->{player}->[0]->{bombs} > 10 || $self->{player}->[1]->{bombs} > 10) ? 2 : 1; - my $hitlen = ($self->{player}->[0]->{hit} > 10 || $self->{player}->[1]->{hit} > 10) ? 2 : 1; - my $misslen = ($self->{player}->[0]->{miss} > 10 || $self->{player}->[1]->{miss} > 10) ? 2 : 1; - my $sunklen = ($self->{player}->[0]->{sunk} > 10 || $self->{player}->[1]->{sunk} > 10) ? 2 : 1; - my $intactlen = ($p1sections > 10 || $p2sections > 10) ? 2 : 1; + my $length_a = length $self->{player}->[0]->{nick}; + my $length_b = length $self->{player}->[1]->{nick}; + my $longest = $length_a > $length_b ? $length_a : $length_b; - my $p1bombscolor = $self->{player}->[0]->{bombs} > $self->{player}->[1]->{bombs} ? $color{green} : $color{red}; - my $p1hitcolor = $self->{player}->[0]->{hit} > $self->{player}->[1]->{hit} ? $color{green} : $color{red}; - my $p1misscolor = $self->{player}->[0]->{miss} < $self->{player}->[1]->{miss} ? $color{green} : $color{red}; - my $p1sunkcolor = $self->{player}->[0]->{sunk} > $self->{player}->[1]->{sunk} ? $color{green} : $color{red}; - my $p1intactcolor = $p1sections > $p2sections ? $color{green} : $color{red}; + my $bombslen = ($self->{player}->[0]->{bombs} > 10 || $self->{player}->[1]->{bombs} > 10) ? 2 : 1; + my $hitlen = ($self->{player}->[0]->{hit} > 10 || $self->{player}->[1]->{hit} > 10) ? 2 : 1; + my $misslen = ($self->{player}->[0]->{miss} > 10 || $self->{player}->[1]->{miss} > 10) ? 2 : 1; + my $sunklen = ($self->{player}->[0]->{sunk} > 10 || $self->{player}->[1]->{sunk} > 10) ? 2 : 1; + my $intactlen = ($p1sections > 10 || $p2sections > 10) ? 2 : 1; - my $p2bombscolor = $self->{player}->[0]->{bombs} < $self->{player}->[1]->{bombs} ? $color{green} : $color{red}; - my $p2hitcolor = $self->{player}->[0]->{hit} < $self->{player}->[1]->{hit} ? $color{green} : $color{red}; - my $p2misscolor = $self->{player}->[0]->{miss} > $self->{player}->[1]->{miss} ? $color{green} : $color{red}; - my $p2sunkcolor = $self->{player}->[0]->{sunk} < $self->{player}->[1]->{sunk} ? $color{green} : $color{red}; - my $p2intactcolor = $p1sections < $p2sections ? $color{green} : $color{red}; + my $p1bombscolor = $self->{player}->[0]->{bombs} > $self->{player}->[1]->{bombs} ? $color{green} : $color{red}; + my $p1hitcolor = $self->{player}->[0]->{hit} > $self->{player}->[1]->{hit} ? $color{green} : $color{red}; + my $p1misscolor = $self->{player}->[0]->{miss} < $self->{player}->[1]->{miss} ? $color{green} : $color{red}; + my $p1sunkcolor = $self->{player}->[0]->{sunk} > $self->{player}->[1]->{sunk} ? $color{green} : $color{red}; + my $p1intactcolor = $p1sections > $p2sections ? $color{green} : $color{red}; - $buf = sprintf("$p1win%*s$color{reset}: bomb: $p1bombscolor%*d$color{reset}, hit: $p1hitcolor%*d$color{reset}, miss: $p1misscolor%*d$color{reset}, sunk: $p1sunkcolor%*d$color{reset}, sections left: $p1intactcolor%*d$color{reset}", - $longest, $self->{player}->[0]->{nick}, $bombslen, $self->{player}->[0]->{bombs}, - $hitlen, $self->{player}->[0]->{hit}, $misslen, $self->{player}->[0]->{miss}, - $sunklen, $self->{player}->[0]->{sunk}, $intactlen, $p1sections); - $self->send_message($self->{channel}, $buf); - $buf = sprintf("$p2win%*s$color{reset}: bomb: $p2bombscolor%*d$color{reset}, hit: $p2hitcolor%*d$color{reset}, miss: $p2misscolor%*d$color{reset}, sunk: $p2sunkcolor%*d$color{reset}, sections left: $p2intactcolor%*d$color{reset}", - $longest, $self->{player}->[1]->{nick}, $bombslen, $self->{player}->[1]->{bombs}, - $hitlen, $self->{player}->[1]->{hit}, $misslen, $self->{player}->[1]->{miss}, - $sunklen, $self->{player}->[1]->{sunk}, $intactlen, $p2sections); - $self->send_message($self->{channel}, $buf); + my $p2bombscolor = $self->{player}->[0]->{bombs} < $self->{player}->[1]->{bombs} ? $color{green} : $color{red}; + my $p2hitcolor = $self->{player}->[0]->{hit} < $self->{player}->[1]->{hit} ? $color{green} : $color{red}; + my $p2misscolor = $self->{player}->[0]->{miss} > $self->{player}->[1]->{miss} ? $color{green} : $color{red}; + my $p2sunkcolor = $self->{player}->[0]->{sunk} < $self->{player}->[1]->{sunk} ? $color{green} : $color{red}; + my $p2intactcolor = $p1sections < $p2sections ? $color{green} : $color{red}; + + $buf = sprintf( + "$p1win%*s$color{reset}: bomb: $p1bombscolor%*d$color{reset}, hit: $p1hitcolor%*d$color{reset}, miss: $p1misscolor%*d$color{reset}, sunk: $p1sunkcolor%*d$color{reset}, sections left: $p1intactcolor%*d$color{reset}", + $longest, $self->{player}->[0]->{nick}, $bombslen, $self->{player}->[0]->{bombs}, + $hitlen, $self->{player}->[0]->{hit}, $misslen, $self->{player}->[0]->{miss}, + $sunklen, $self->{player}->[0]->{sunk}, $intactlen, $p1sections + ); + $self->send_message($self->{channel}, $buf); + $buf = sprintf( + "$p2win%*s$color{reset}: bomb: $p2bombscolor%*d$color{reset}, hit: $p2hitcolor%*d$color{reset}, miss: $p2misscolor%*d$color{reset}, sunk: $p2sunkcolor%*d$color{reset}, sections left: $p2intactcolor%*d$color{reset}", + $longest, $self->{player}->[1]->{nick}, $bombslen, $self->{player}->[1]->{bombs}, + $hitlen, $self->{player}->[1]->{hit}, $misslen, $self->{player}->[1]->{miss}, + $sunklen, $self->{player}->[1]->{sunk}, $intactlen, $p2sections + ); + $self->send_message($self->{channel}, $buf); } sub show_battlefield { - my ($self, $player, $nick) = @_; - my ($x, $y, $buf); + my ($self, $player, $nick) = @_; + my ($x, $y, $buf); - $self->{pbot}->{logger}->log("showing battlefield for player $player\n"); + $self->{pbot}->{logger}->log("showing battlefield for player $player\n"); - $buf = "$color{cyan},01 "; + $buf = "$color{cyan},01 "; - for($x = 1; $x < $self->{N_X} + 1; $x++) { - if ($x % 10 == 0) { - $buf .= "$color{yellow},01" if $self->{N_X} > 10; - $buf .= $x % 10; - $buf .= ' '; - $buf .= "$color{cyan},01" if $self->{N_X} > 10; + for ($x = 1; $x < $self->{N_X} + 1; $x++) { + if ($x % 10 == 0) { + $buf .= "$color{yellow},01" if $self->{N_X} > 10; + $buf .= $x % 10; + $buf .= ' '; + $buf .= "$color{cyan},01" if $self->{N_X} > 10; + } else { + $buf .= $x % 10; + $buf .= ' '; + } + } + + $buf .= "\n"; + + for ($y = 0; $y < $self->{N_Y}; $y++) { + $buf .= sprintf("$color{cyan},01%c ", 97 + $y); + for ($x = 0; $x < $self->{N_X}; $x++) { + if ($player == 0) { + if ($self->{board}->[$y][$x] eq $self->{player_two_vert} || $self->{board}->[$y][$x] eq $self->{player_two_horiz}) { + $buf .= "$color{blue},01~ "; + next; + } else { + if ($self->{board}->[$y][$x] eq '1' || $self->{board}->[$y][$x] eq '2') { $buf .= "$color{red},01"; } + elsif ($self->{board}->[$y][$x] eq 'o' || $self->{board}->[$y][$x] eq '*') { $buf .= "$color{cyan},01"; } + elsif ($self->{board}->[$y][$x] eq '~') { + $buf .= "$color{blue},01~ "; + next; + } else { + $buf .= "$color{white},01"; + } + $buf .= "$self->{board}->[$y][$x] "; + $self->{pbot}->{logger}->log("$y, $x: $self->{board}->[$y][$x]\n"); + } + } elsif ($player == 1) { + if ($self->{board}->[$y][$x] eq $self->{player_one_vert} || $self->{board}->[$y][$x] eq $self->{player_one_horiz}) { + $buf .= "$color{blue},01~ "; + next; + } else { + if ($self->{board}->[$y][$x] eq '1' || $self->{board}->[$y][$x] eq '2') { $buf .= "$color{red},01"; } + elsif ($self->{board}->[$y][$x] eq 'o' || $self->{board}->[$y][$x] eq '*') { $buf .= "$color{cyan},01"; } + elsif ($self->{board}->[$y][$x] eq '~') { + $buf .= "$color{blue},01~ "; + next; + } else { + $buf .= "$color{white},01"; + } + $buf .= "$self->{board}->[$y][$x] "; + } + } elsif ($player == 2) { + if ( $self->{board}->[$y][$x] eq $self->{player_one_vert} + || $self->{board}->[$y][$x] eq $self->{player_one_horiz} + || $self->{board}->[$y][$x] eq $self->{player_two_vert} + || $self->{board}->[$y][$x] eq $self->{player_two_horiz}) + { + $buf .= "$color{blue},01~ "; + next; + } else { + if ($self->{board}->[$y][$x] eq '1' || $self->{board}->[$y][$x] eq '2') { $buf .= "$color{red},01"; } + elsif ($self->{board}->[$y][$x] eq 'o' || $self->{board}->[$y][$x] eq '*') { $buf .= "$color{cyan},01"; } + elsif ($self->{board}->[$y][$x] eq '~') { + $buf .= "$color{blue},01~ "; + next; + } else { + $buf .= "$color{white},01"; + } + $buf .= "$self->{board}->[$y][$x] "; + } + } else { + if ($self->{board}->[$y][$x] eq '1' || $self->{board}->[$y][$x] eq '2') { $buf .= "$color{red},01"; } + elsif ($self->{board}->[$y][$x] eq 'o' || $self->{board}->[$y][$x] eq '*') { $buf .= "$color{cyan},01"; } + elsif ($self->{board}->[$y][$x] eq '~') { + $buf .= "$color{blue},01~ "; + next; + } else { + $buf .= "$color{white},01"; + } + $buf .= "$self->{board}->[$y][$x] "; + } + } + $buf .= sprintf("$color{cyan},01%c", 97 + $y); + $buf .= "$color{reset}\n"; + } + + # bottom border + $buf .= "$color{cyan},01 "; + + for ($x = 1; $x < $self->{N_X} + 1; $x++) { + if ($x % 10 == 0) { + $buf .= $color{yellow}, 01 if $self->{N_X} > 10; + $buf .= $x % 10; + $buf .= ' '; + $buf .= $color{cyan}, 01 if $self->{N_X} > 10; + } else { + $buf .= $x % 10; + $buf .= ' '; + } + } + + $buf .= "\n"; + + my $player1 = $self->{player}->[0]->{nick}; + my $player2 = $self->{player}->[1]->{nick}; + + if ($player == 0) { + $self->send_message( + $self->{player}->[$player]->{nick}, + "Player One Legend: ships: [| -] ocean: [$color{blue},01~$color{reset}] $player1 miss: [$color{cyan},01*$color{reset}] $player2 miss: [$color{cyan},01o$color{reset}] $player1 hit: [$color{red},01" + . "1" + . "$color{reset}] $player2 hit: [$color{red},012$color{reset}]" + ); + } elsif ($player == 1) { + $self->send_message( + $self->{player}->[$player]->{nick}, + "Player Two Legend: ships: [I =] ocean: [$color{blue},01~$color{reset}] $player1 miss: [$color{cyan},01*$color{reset}] $player2 miss: [$color{cyan},01o$color{reset}] $player1 hit: [$color{red},01" + . "1" + . "$color{reset}] $player2 hit: [$color{red},012$color{reset}]" + ); + } elsif ($player == 2) { + $self->send_message( + $self->{channel}, + "Spectator Legend: ocean: [$color{blue},01~$color{reset}] $player1 miss: [$color{cyan},01*$color{reset}] $player2 miss: [$color{cyan},01o$color{reset}] $player1 hit: [$color{red},01" + . "1" + . "$color{reset}] $player2 hit: [$color{red},012$color{reset}]" + ); + } elsif ($player == 3) { + $self->send_message( + $self->{channel}, + "Final Board Legend: $player1 ships: [| -] $player2 ships: [I =] ocean: [$color{blue},01~$color{reset}] $player1 miss: [$color{cyan},01*$color{reset}] $player2 miss: [$color{cyan},01o$color{reset}] $player1 hit: [$color{red},01" + . "1" + . "$color{reset}] $player2 hit: [$color{red},012$color{reset}]" + ); } else { - $buf .= $x % 10; - $buf .= ' '; + $self->send_message( + $nick, + "Full Board Legend: $player1 ships: [| -] $player2 ships: [I =] ocean: [$color{blue},01~$color{reset}] $player1 miss: [$color{cyan},01*$color{reset}] $player2 miss: [$color{cyan},01o$color{reset}] $player1 hit: [$color{red},01" + . "1" + . "$color{reset}] $player2 hit: [$color{red},012$color{reset}]" + ); } - } - $buf .= "\n"; - - for ($y = 0; $y < $self->{N_Y}; $y++) { - $buf .= sprintf("$color{cyan},01%c ", 97 + $y); - for ($x = 0; $x < $self->{N_X}; $x++) { - if ($player == 0) { - if ($self->{board}->[$y][$x] eq $self->{player_two_vert} || $self->{board}->[$y][$x] eq $self->{player_two_horiz}) { - $buf .= "$color{blue},01~ "; - next; - } else { - if ($self->{board}->[$y][$x] eq '1' || $self->{board}->[$y][$x] eq '2') { - $buf .= "$color{red},01"; - } elsif ($self->{board}->[$y][$x] eq 'o' || $self->{board}->[$y][$x] eq '*') { - $buf .= "$color{cyan},01"; - } elsif ($self->{board}->[$y][$x] eq '~') { - $buf .= "$color{blue},01~ "; - next; - } else { - $buf .= "$color{white},01"; - } - $buf .= "$self->{board}->[$y][$x] "; - $self->{pbot}->{logger}->log("$y, $x: $self->{board}->[$y][$x]\n"); - } - } elsif ($player == 1) { - if ($self->{board}->[$y][$x] eq $self->{player_one_vert} || $self->{board}->[$y][$x] eq $self->{player_one_horiz}) { - $buf .= "$color{blue},01~ "; - next; - } else { - if ($self->{board}->[$y][$x] eq '1' || $self->{board}->[$y][$x] eq '2') { - $buf .= "$color{red},01"; - } elsif ($self->{board}->[$y][$x] eq 'o' || $self->{board}->[$y][$x] eq '*') { - $buf .= "$color{cyan},01"; - } elsif ($self->{board}->[$y][$x] eq '~') { - $buf .= "$color{blue},01~ "; - next; - } else { - $buf .= "$color{white},01"; - } - $buf .= "$self->{board}->[$y][$x] "; - } - } elsif ($player == 2) { - if ($self->{board}->[$y][$x] eq $self->{player_one_vert} || $self->{board}->[$y][$x] eq $self->{player_one_horiz} - || $self->{board}->[$y][$x] eq $self->{player_two_vert} || $self->{board}->[$y][$x] eq $self->{player_two_horiz}) { - $buf .= "$color{blue},01~ "; - next; - } else { - if ($self->{board}->[$y][$x] eq '1' || $self->{board}->[$y][$x] eq '2') { - $buf .= "$color{red},01"; - } elsif ($self->{board}->[$y][$x] eq 'o' || $self->{board}->[$y][$x] eq '*') { - $buf .= "$color{cyan},01"; - } elsif ($self->{board}->[$y][$x] eq '~') { - $buf .= "$color{blue},01~ "; - next; - } else { - $buf .= "$color{white},01"; - } - $buf .= "$self->{board}->[$y][$x] "; - } - } else { - if ($self->{board}->[$y][$x] eq '1' || $self->{board}->[$y][$x] eq '2') { - $buf .= "$color{red},01"; - } elsif ($self->{board}->[$y][$x] eq 'o' || $self->{board}->[$y][$x] eq '*') { - $buf .= "$color{cyan},01"; - } elsif ($self->{board}->[$y][$x] eq '~') { - $buf .= "$color{blue},01~ "; - next; - } else { - $buf .= "$color{white},01"; - } - $buf .= "$self->{board}->[$y][$x] "; - } + foreach my $line (split /\n/, $buf) { + if ($player == 0 || $player == 1) { $self->send_message($self->{player}->[$player]->{nick}, $line); } + elsif ($player == 2 || $player == 3) { $self->send_message($self->{channel}, $line); } + else { $self->send_message($nick, $line); } } - $buf .= sprintf("$color{cyan},01%c", 97 + $y); - $buf .= "$color{reset}\n"; - } - - # bottom border - $buf .= "$color{cyan},01 "; - - for($x = 1; $x < $self->{N_X} + 1; $x++) { - if ($x % 10 == 0) { - $buf .= $color{yellow},01 if $self->{N_X} > 10; - $buf .= $x % 10; - $buf .= ' '; - $buf .= $color{cyan},01 if $self->{N_X} > 10; - } else { - $buf .= $x % 10; - $buf .= ' '; - } - } - - $buf .= "\n"; - - my $player1 = $self->{player}->[0]->{nick}; - my $player2 = $self->{player}->[1]->{nick}; - - if ($player == 0) { - $self->send_message($self->{player}->[$player]->{nick}, "Player One Legend: ships: [| -] ocean: [$color{blue},01~$color{reset}] $player1 miss: [$color{cyan},01*$color{reset}] $player2 miss: [$color{cyan},01o$color{reset}] $player1 hit: [$color{red},01"."1"."$color{reset}] $player2 hit: [$color{red},012$color{reset}]"); - } elsif ($player == 1) { - $self->send_message($self->{player}->[$player]->{nick}, "Player Two Legend: ships: [I =] ocean: [$color{blue},01~$color{reset}] $player1 miss: [$color{cyan},01*$color{reset}] $player2 miss: [$color{cyan},01o$color{reset}] $player1 hit: [$color{red},01"."1"."$color{reset}] $player2 hit: [$color{red},012$color{reset}]"); - } elsif ($player == 2) { - $self->send_message($self->{channel}, "Spectator Legend: ocean: [$color{blue},01~$color{reset}] $player1 miss: [$color{cyan},01*$color{reset}] $player2 miss: [$color{cyan},01o$color{reset}] $player1 hit: [$color{red},01"."1"."$color{reset}] $player2 hit: [$color{red},012$color{reset}]"); - } elsif ($player == 3) { - $self->send_message($self->{channel}, "Final Board Legend: $player1 ships: [| -] $player2 ships: [I =] ocean: [$color{blue},01~$color{reset}] $player1 miss: [$color{cyan},01*$color{reset}] $player2 miss: [$color{cyan},01o$color{reset}] $player1 hit: [$color{red},01"."1"."$color{reset}] $player2 hit: [$color{red},012$color{reset}]"); - } else { - $self->send_message($nick, "Full Board Legend: $player1 ships: [| -] $player2 ships: [I =] ocean: [$color{blue},01~$color{reset}] $player1 miss: [$color{cyan},01*$color{reset}] $player2 miss: [$color{cyan},01o$color{reset}] $player1 hit: [$color{red},01"."1"."$color{reset}] $player2 hit: [$color{red},012$color{reset}]"); - } - - foreach my $line (split /\n/, $buf) { - if ($player == 0 || $player == 1) { - $self->send_message($self->{player}->[$player]->{nick}, $line); - } elsif ($player == 2 || $player == 3) { - $self->send_message($self->{channel}, $line); - } else { - $self->send_message($nick, $line); - } - } } # state subroutines sub nogame { - my ($self, $state) = @_; - $state->{result} = 'nogame'; - return $state; + my ($self, $state) = @_; + $state->{result} = 'nogame'; + return $state; } sub accept { - my ($self, $state) = @_; + my ($self, $state) = @_; - $state->{max_count} = 3; + $state->{max_count} = 3; - if ($state->{players}->[1]->{accepted}) { - $state->{result} = 'accept'; + if ($state->{players}->[1]->{accepted}) { + $state->{result} = 'accept'; + return $state; + } + + my $tock = 15; + + if ($state->{ticks} % $tock == 0) { + $state->{tocked} = 1; + + if (++$state->{counter} > $state->{max_count}) { + if ($state->{players}->[1]->{id} == -1) { $self->send_message($self->{channel}, "Nobody has accepted $state->{players}->[0]->{name}'s challenge."); } + else { $self->send_message($self->{channel}, "$state->{players}->[1]->{name} has failed to accept $state->{players}->[0]->{name}'s challenge."); } + $state->{result} = 'stop'; + $state->{players} = []; + return $state; + } + + if ($state->{players}->[1]->{id} == -1) { + $self->send_message($self->{channel}, "$state->{players}->[0]->{name} has made an open challenge! Use `accept` to accept their challenge."); + } else { + $self->send_message($self->{channel}, "$state->{players}->[1]->{name}: $state->{players}->[0]->{name} has challenged you! Use `accept` to accept their challenge."); + } + } + + $state->{result} = 'wait'; return $state; - } - - my $tock = 15; - - if ($state->{ticks} % $tock == 0) { - $state->{tocked} = 1; - - if (++$state->{counter} > $state->{max_count}) { - if ($state->{players}->[1]->{id} == -1) { - $self->send_message($self->{channel}, "Nobody has accepted $state->{players}->[0]->{name}'s challenge."); - } else { - $self->send_message($self->{channel}, "$state->{players}->[1]->{name} has failed to accept $state->{players}->[0]->{name}'s challenge."); - } - $state->{result} = 'stop'; - $state->{players} = []; - return $state; - } - - if ($state->{players}->[1]->{id} == -1) { - $self->send_message($self->{channel}, "$state->{players}->[0]->{name} has made an open challenge! Use `accept` to accept their challenge."); - } else { - $self->send_message($self->{channel}, "$state->{players}->[1]->{name}: $state->{players}->[0]->{name} has challenged you! Use `accept` to accept their challenge."); - } - } - - $state->{result} = 'wait'; - return $state; } sub genboard { - my ($self, $state) = @_; - $self->init_game($state->{players}->[0]->{name}, $state->{players}->[1]->{name}); - $state->{current_player} = 0; - $state->{max_count} = 3; - $state->{result} = 'next'; - return $state; + my ($self, $state) = @_; + $self->init_game($state->{players}->[0]->{name}, $state->{players}->[1]->{name}); + $state->{current_player} = 0; + $state->{max_count} = 3; + $state->{result} = 'next'; + return $state; } sub showboard { - my ($self, $state) = @_; - $self->send_message($self->{channel}, "Showing battlefield to $self->{player}->[0]->{nick}..."); - $self->show_battlefield(0); - $self->send_message($self->{channel}, "Showing battlefield to $self->{player}->[1]->{nick}..."); - $self->show_battlefield(1); - $self->send_message($self->{channel}, "Fight! Anybody (players and spectators) can use `board` at any time to see the battlefield."); - $state->{result} = 'next'; - return $state; + my ($self, $state) = @_; + $self->send_message($self->{channel}, "Showing battlefield to $self->{player}->[0]->{nick}..."); + $self->show_battlefield(0); + $self->send_message($self->{channel}, "Showing battlefield to $self->{player}->[1]->{nick}..."); + $self->show_battlefield(1); + $self->send_message($self->{channel}, "Fight! Anybody (players and spectators) can use `board` at any time to see the battlefield."); + $state->{result} = 'next'; + return $state; } sub playermove { - my ($self, $state) = @_; + my ($self, $state) = @_; - my $tock; - if ($state->{first_tock}) { - $tock = 3; - } else { - $tock = 15; - } + my $tock; + if ($state->{first_tock}) { $tock = 3; } + else { $tock = 15; } - if ($self->{player}->[$state->{current_player}]->{done}) { - $self->{pbot}->{logger}->log("playermove: player $state->{current_player} done, nexting\n"); - $state->{result} = 'next'; + if ($self->{player}->[$state->{current_player}]->{done}) { + $self->{pbot}->{logger}->log("playermove: player $state->{current_player} done, nexting\n"); + $state->{result} = 'next'; + return $state; + } + + my $player = $state->{current_player}; + my $location = delete $state->{players}->[$player]->{location}; + + if (defined $location) { + if ($self->bomb($player, uc $location)) { + $self->{player}->[$player]->{done} = 1; + $self->{player}->[!$player]->{done} = 0; + $self->{state_data}->{current_player} = !$player; + $state->{result} = 'next'; + return $state; + } + } + + if ($state->{ticks} % $tock == 0) { + $state->{tocked} = 1; + if (++$state->{counter} > $state->{max_count}) { + $state->{players}->[$state->{current_player}]->{missedinputs}++; + $self->send_message($self->{channel}, "$state->{players}->[$state->{current_player}]->{name} failed to launch an attack in time. They forfeit their turn!"); + $self->{player}->[$state->{current_player}]->{done} = 1; + $self->{player}->[!$state->{current_player}]->{done} = 0; + $state->{current_player} = !$state->{current_player}; + $state->{result} = 'next'; + return $state; + } + + my $red = $state->{counter} == $state->{max_count} ? $color{red} : ''; + + my $remaining = 15 * $state->{max_count}; + $remaining -= 15 * ($state->{counter} - 1); + $remaining = "(" . (concise duration $remaining) . " remaining)"; + + $self->send_message($self->{channel}, "$state->{players}->[$state->{current_player}]->{name}: $red$remaining Launch an attack now via `bomb `!$color{reset}"); + } + + $state->{result} = 'wait'; return $state; - } - - my $player = $state->{current_player}; - my $location = delete $state->{players}->[$player]->{location}; - - if (defined $location) { - if ($self->bomb($player, uc $location)) { - $self->{player}->[$player]->{done} = 1; - $self->{player}->[!$player]->{done} = 0; - $self->{state_data}->{current_player} = !$player; - $state->{result} = 'next'; - return $state; - } - } - - if ($state->{ticks} % $tock == 0) { - $state->{tocked} = 1; - if (++$state->{counter} > $state->{max_count}) { - $state->{players}->[$state->{current_player}]->{missedinputs}++; - $self->send_message($self->{channel}, "$state->{players}->[$state->{current_player}]->{name} failed to launch an attack in time. They forfeit their turn!"); - $self->{player}->[$state->{current_player}]->{done} = 1; - $self->{player}->[!$state->{current_player}]->{done} = 0; - $state->{current_player} = !$state->{current_player}; - $state->{result} = 'next'; - return $state; - } - - my $red = $state->{counter} == $state->{max_count} ? $color{red} : ''; - - my $remaining = 15 * $state->{max_count}; - $remaining -= 15 * ($state->{counter} - 1); - $remaining = "(" . (concise duration $remaining) . " remaining)"; - - $self->send_message($self->{channel}, "$state->{players}->[$state->{current_player}]->{name}: $red$remaining Launch an attack now via `bomb `!$color{reset}"); - } - - $state->{result} = 'wait'; - return $state; } sub checkplayer { - my ($self, $state) = @_; + my ($self, $state) = @_; - if ($self->{player}->[0]->{won} or $self->{player}->[1]->{won}) { - $state->{result} = 'sunk'; - } else { - $state->{result} = 'next'; - } - return $state; + if ($self->{player}->[0]->{won} or $self->{player}->[1]->{won}) { $state->{result} = 'sunk'; } + else { $state->{result} = 'next'; } + return $state; } sub gameover { - my ($self, $state) = @_; - if ($state->{ticks} % 5 == 0) { - if ($state->{players}->[1]->{id} != -1 && $state->{players}->[1]->{accepted}) { - $self->show_battlefield(3); - $self->show_scoreboard; - $self->send_message($self->{channel}, "Game over!"); + my ($self, $state) = @_; + if ($state->{ticks} % 5 == 0) { + if ($state->{players}->[1]->{id} != -1 && $state->{players}->[1]->{accepted}) { + $self->show_battlefield(3); + $self->show_scoreboard; + $self->send_message($self->{channel}, "Game over!"); + } + $state->{players} = []; + $state->{counter} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; } - $state->{players} = []; - $state->{counter} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + return $state; } 1; diff --git a/Plugins/Connect4.pm b/Plugins/Connect4.pm index d158cfb6..b4a34eb2 100644 --- a/Plugins/Connect4.pm +++ b/Plugins/Connect4.pm @@ -14,876 +14,790 @@ no if $] >= 5.018, warnings => "experimental::smartmatch"; use Time::Duration qw/concise duration/; use Data::Dumper; use List::Util qw[min max]; -$Data::Dumper::Useqq = 1; +$Data::Dumper::Useqq = 1; $Data::Dumper::Sortkeys = 1; sub initialize { - my ($self, %conf) = @_; - $self->{pbot}->{commands}->register(sub { $self->connect4_cmd(@_) }, 'connect4', 0); + my ($self, %conf) = @_; + $self->{pbot}->{commands}->register(sub { $self->connect4_cmd(@_) }, 'connect4', 0); - $self->{pbot}->{timer}->register(sub { $self->connect4_timer }, 1, 'connect4 timer'); + $self->{pbot}->{timer}->register(sub { $self->connect4_timer }, 1, 'connect4 timer'); - $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.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->{channel} = $self->{pbot}->{registry}->get_value('connect4', 'channel') // '##connect4'; - $self->{debug} = $self->{pbot}->{registry}->get_value('connect4', 'debug') // 0; - $self->create_states; + $self->{channel} = $self->{pbot}->{registry}->get_value('connect4', 'channel') // '##connect4'; + $self->{debug} = $self->{pbot}->{registry}->get_value('connect4', 'debug') // 0; + $self->create_states; } sub unload { - my $self = shift; - $self->{pbot}->{commands}->unregister('connect4'); - $self->{pbot}->{timer}->unregister('connect4 timer'); - $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->{pbot}->{commands}->unregister('connect4'); + $self->{pbot}->{timer}->unregister('connect4 timer'); + $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 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 lc $channel ne $self->{channel}; - $self->player_left($nick, $user, $host); - return 0; + 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 lc $channel ne $self->{channel}; + $self->player_left($nick, $user, $host); + return 0; } sub on_departure { - my ($self, $event_type, $event) = @_; - my ($nick, $user, $host, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to); - my $type = uc $event->{event}->type; - return 0 if $type ne 'QUIT' and lc $channel ne $self->{channel}; - $self->player_left($nick, $user, $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); + my $type = uc $event->{event}->type; + return 0 if $type ne 'QUIT' and lc $channel ne $self->{channel}; + $self->player_left($nick, $user, $host); + return 0; } my %color = ( - white => "\x0300", - black => "\x0301", - blue => "\x0302", - green => "\x0303", - red => "\x0304", - maroon => "\x0305", - purple => "\x0306", - orange => "\x0307", - yellow => "\x0308", - lightgreen => "\x0309", - teal => "\x0310", - cyan => "\x0311", - lightblue => "\x0312", - magneta => "\x0313", - gray => "\x0314", - lightgray => "\x0315", + white => "\x0300", + black => "\x0301", + blue => "\x0302", + green => "\x0303", + red => "\x0304", + maroon => "\x0305", + purple => "\x0306", + orange => "\x0307", + yellow => "\x0308", + lightgreen => "\x0309", + teal => "\x0310", + cyan => "\x0311", + lightblue => "\x0312", + magneta => "\x0313", + gray => "\x0314", + lightgray => "\x0315", - bold => "\x02", - italics => "\x1D", - underline => "\x1F", - reverse => "\x16", + bold => "\x02", + italics => "\x1D", + underline => "\x1F", + reverse => "\x16", - reset => "\x0F", + reset => "\x0F", ); -my $DEFAULT_NX = 7; -my $DEFAULT_NY = 6; +my $DEFAULT_NX = 7; +my $DEFAULT_NY = 6; my $DEFAULT_CONNECTIONS = 4; -my $MAX_NX = 80; -my $MAX_NY = 12; +my $MAX_NX = 80; +my $MAX_NY = 12; # challenge options: CONNS:ROWSxCOLS sub parse_challenge { - my ($self, $options) = @_; - my ($conns, $xy, $nx, $ny); + my ($self, $options) = @_; + my ($conns, $xy, $nx, $ny); - "x" =~ /x/; # clear $1, $2 ... - if ($options !~ m/^(\d+)(:(\d+)x(\d+))?$/) { - return "Invalid options '$options', use: "; - } + "x" =~ /x/; # clear $1, $2 ... + if ($options !~ m/^(\d+)(:(\d+)x(\d+))?$/) { return "Invalid options '$options', use: "; } - $conns = $1; - $xy = $2; - $ny = $3; - $nx = $4; + $conns = $1; + $xy = $2; + $ny = $3; + $nx = $4; - $self->{N_X} = (not length $nx) ? $DEFAULT_NX : $nx; - $self->{N_Y} = (not length $ny) ? $DEFAULT_NY : $ny; - $self->{CONNECTIONS} = (not length $conns) ? $DEFAULT_CONNECTIONS : $conns; + $self->{N_X} = (not length $nx) ? $DEFAULT_NX : $nx; + $self->{N_Y} = (not length $ny) ? $DEFAULT_NY : $ny; + $self->{CONNECTIONS} = (not length $conns) ? $DEFAULT_CONNECTIONS : $conns; - # auto adjust board size for `challenge N' - if ((not length $xy) && ($self->{CONNECTIONS} >= $self->{N_X} || $self->{CONNECTIONS} >= $self->{N_Y})) { - $self->{N_X} = min($self->{CONNECTIONS} * 2 - 1, $MAX_NX); - $self->{N_Y} = min($self->{CONNECTIONS} * 2 - 2, $MAX_NY); - } + # auto adjust board size for `challenge N' + if ((not length $xy) && ($self->{CONNECTIONS} >= $self->{N_X} || $self->{CONNECTIONS} >= $self->{N_Y})) { + $self->{N_X} = min($self->{CONNECTIONS} * 2 - 1, $MAX_NX); + $self->{N_Y} = min($self->{CONNECTIONS} * 2 - 2, $MAX_NY); + } - if ($self->{N_X} > $MAX_NX || $self->{N_Y} > $MAX_NY) { - return "Invalid board options '$self->{CONNECTIONS}:$self->{N_Y}x$self->{N_X}', " . - "maximum board size is: ${MAX_NY}x${MAX_NX}."; - } + if ($self->{N_X} > $MAX_NX || $self->{N_Y} > $MAX_NY) { + return "Invalid board options '$self->{CONNECTIONS}:$self->{N_Y}x$self->{N_X}', " . "maximum board size is: ${MAX_NY}x${MAX_NX}."; + } - if ($self->{N_X} < $self->{CONNECTIONS} && $self->{N_Y} < $self->{CONNECTIONS}) { - return "Invalid board options '$self->{CONNECTIONS}:$self->{N_Y}x$self->{N_X}', " . - "rows or columns must be >= than connections."; - } + if ($self->{N_X} < $self->{CONNECTIONS} && $self->{N_Y} < $self->{CONNECTIONS}) { + return "Invalid board options '$self->{CONNECTIONS}:$self->{N_Y}x$self->{N_X}', " . "rows or columns must be >= than connections."; + } - return 0; + return 0; } sub connect4_cmd { - my ($self, $from, $nick, $user, $host, $arguments) = @_; - my ($options, $command, $err); + my ($self, $from, $nick, $user, $host, $arguments) = @_; + my ($options, $command, $err); - $arguments =~ s/^\s+|\s+$//g; + $arguments =~ s/^\s+|\s+$//g; - my $usage = "Usage: connect4 challenge|accept|play|board|quit|players|kick|abort; for more information about a command: connect4 help "; + my $usage = "Usage: connect4 challenge|accept|play|board|quit|players|kick|abort; for more information about a command: connect4 help "; - ($command, $arguments, $options) = split / /, $arguments, 3; - $command = lc $command; + ($command, $arguments, $options) = split / /, $arguments, 3; + $command = lc $command; - my ($channel, $result); + my ($channel, $result); - given ($command) { - when ('help') { - given ($arguments) { + given ($command) { when ('help') { - return "Seriously?"; + given ($arguments) { + when ('help') { return "Seriously?"; } + + when ('challenge') { return "challenge [nick] [connections[:ROWSxCOLS]] -- connections has to be <= than rows or columns (duh!)."; } + + default { + if (length $arguments) { return "connect4 has no such command '$arguments'. I can't help you with that."; } + else { return "Usage: connect4 help "; } + } + } } - when ('challenge') { - return "challenge [nick] [connections[:ROWSxCOLS]] -- connections has to be <= than rows or columns (duh!)."; - } + when ('challenge') { + if ($self->{current_state} ne 'nogame') { return "There is already a game of connect4 underway."; } - default { - if (length $arguments) { - return "connect4 has no such command '$arguments'. I can't help you with that."; - } else { - return "Usage: connect4 help "; - } + $self->{N_X} = $DEFAULT_NX; + $self->{N_Y} = $DEFAULT_NY; + $self->{CONNECTIONS} = $DEFAULT_CONNECTIONS; + + if ((not length $arguments) || ($arguments =~ m/^\d+.*$/ && not($err = $self->parse_challenge($arguments)))) { + $self->{current_state} = 'accept'; + $self->{state_data} = {players => [], counter => 0}; + + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + my $player = {id => $id, name => $nick, missedinputs => 0}; + push @{$self->{state_data}->{players}}, $player; + + $player = {id => -1, name => undef, missedinputs => 0}; + push @{$self->{state_data}->{players}}, $player; + return "/msg $self->{channel} $nick has made an open challenge (Connect-$self->{CONNECTIONS} @ " + . "$self->{N_Y}x$self->{N_X} board)! Use `accept` to accept their challenge."; + } + + if ($err) { return $err; } + + my $challengee = $self->{pbot}->{nicklist}->is_present($self->{channel}, $arguments); + + if (not $challengee) { return "That nick is not present in this channel. Invite them to $self->{channel} and try again!"; } + + $self->{current_state} = 'accept'; + $self->{state_data} = {players => [], counter => 0}; + + if (length $options) { + if ($err = $self->parse_challenge($options)) { return $err; } + } + + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + my $player = {id => $id, name => $nick, missedinputs => 0}; + push @{$self->{state_data}->{players}}, $player; + + ($id) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($challengee); + $player = {id => $id, name => $challengee, missedinputs => 0}; + push @{$self->{state_data}->{players}}, $player; + + return "/msg $self->{channel} $nick has challenged $challengee to " + . "Connect-$self->{CONNECTIONS} @ $self->{N_Y}x$self->{N_X} board! Use `accept` to accept their challenge."; } - } - } - when ('challenge') { - if ($self->{current_state} ne 'nogame') { - return "There is already a game of connect4 underway."; - } + when ('accept') { + if ($self->{current_state} ne 'accept') { return "/msg $nick This is not the time to use `accept`."; } - $self->{N_X} = $DEFAULT_NX; - $self->{N_Y} = $DEFAULT_NY; - $self->{CONNECTIONS} = $DEFAULT_CONNECTIONS; + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + my $player = $self->{state_data}->{players}->[1]; - if ((not length $arguments) || ($arguments =~ m/^\d+.*$/ && not ($err = $self->parse_challenge($arguments)))) { - $self->{current_state} = 'accept'; - $self->{state_data} = { players => [], counter => 0 }; + # open challenge + if ($player->{id} == -1) { + $player->{id} = $id; + $player->{name} = $nick; + } - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - my $player = { id => $id, name => $nick, missedinputs => 0 }; - push @{$self->{state_data}->{players}}, $player; - - $player = { id => -1, name => undef, missedinputs => 0 }; - push @{$self->{state_data}->{players}}, $player; - return "/msg $self->{channel} $nick has made an open challenge (Connect-$self->{CONNECTIONS} @ " . - "$self->{N_Y}x$self->{N_X} board)! Use `accept` to accept their challenge."; - } - - if ($err) { - return $err; - } - - my $challengee = $self->{pbot}->{nicklist}->is_present($self->{channel}, $arguments); - - if (not $challengee) { - return "That nick is not present in this channel. Invite them to $self->{channel} and try again!"; - } - - $self->{current_state} = 'accept'; - $self->{state_data} = { players => [], counter => 0 }; - - if (length $options) { - if ($err = $self->parse_challenge($options)) { - return $err; + if ($player->{id} == $id) { + $player->{accepted} = 1; + return "/msg $self->{channel} $nick has accepted $self->{state_data}->{players}->[0]->{name}'s challenge!"; + } else { + return "/msg $nick You have not been challenged to a game of Connect4 yet."; + } } - } - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - my $player = { id => $id, name => $nick, missedinputs => 0 }; - push @{$self->{state_data}->{players}}, $player; + when ($_ eq 'decline' or $_ eq 'quit' or $_ eq 'forfeit' or $_ eq 'concede') { + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + my $removed = 0; - ($id) = $self->{pbot}->{messagehistory}->{database}->find_message_account_by_nick($challengee); - $player = { id => $id, name => $challengee, missedinputs => 0 }; - push @{$self->{state_data}->{players}}, $player; + for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { + if ($self->{state_data}->{players}->[$i]->{id} == $id) { + splice @{$self->{state_data}->{players}}, $i--, 1; + $removed = 1; + } + } - return "/msg $self->{channel} $nick has challenged $challengee to " . - "Connect-$self->{CONNECTIONS} @ $self->{N_Y}x$self->{N_X} board! Use `accept` to accept their challenge."; - } - - when ('accept') { - if ($self->{current_state} ne 'accept') { - return "/msg $nick This is not the time to use `accept`."; - } - - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - my $player = $self->{state_data}->{players}->[1]; - - # open challenge - if ($player->{id} == -1) { - $player->{id} = $id; - $player->{name} = $nick; - } - - if ($player->{id} == $id) { - $player->{accepted} = 1; - return "/msg $self->{channel} $nick has accepted $self->{state_data}->{players}->[0]->{name}'s challenge!"; - } else { - return "/msg $nick You have not been challenged to a game of Connect4 yet."; - } - } - - when ($_ eq 'decline' or $_ eq 'quit' or $_ eq 'forfeit' or $_ eq 'concede') { - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - my $removed = 0; - - for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { - if ($self->{state_data}->{players}->[$i]->{id} == $id) { - splice @{$self->{state_data}->{players}}, $i--, 1; - $removed = 1; + if ($removed) { + if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 } + return "/msg $self->{channel} $nick has left the game!"; + } else { + return "$nick: But you are not even playing the game."; + } } - } - if ($removed) { - if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { - $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 + when ('abort') { + if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { return "$nick: Sorry, only admins may abort the game."; } + + $self->{current_state} = 'gameover'; + return "/msg $self->{channel} $nick: The game has been aborted."; } - return "/msg $self->{channel} $nick has left the game!"; - } else { - return "$nick: But you are not even playing the game."; - } - } - when ('abort') { - if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { - return "$nick: Sorry, only admins may abort the game."; - } - - $self->{current_state} = 'gameover'; - return "/msg $self->{channel} $nick: The game has been aborted."; - } - - when ('players') { - if ($self->{current_state} eq 'accept') { - return "$self->{state_data}->{players}->[0]->{name} has challenged $self->{state_data}->{players}->[1]->{name}!"; - } elsif (@{$self->{state_data}->{players}} == 2) { - return "$self->{state_data}->{players}->[0]->{name} is playing with $self->{state_data}->{players}->[1]->{name}!"; - } else { - return "There are no players playing right now. Start a game with `connect4 challenge `!"; - } - } - - when ('kick') { - if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { - return "$nick: Sorry, only admins may kick people from the game."; - } - - if (not length $arguments) { - return "Usage: connect4 kick "; - } - - my $removed = 0; - - for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { - if (lc $self->{state_data}->{players}->[$i]->{name} eq $arguments) { - splice @{$self->{state_data}->{players}}, $i--, 1; - $removed = 1; + when ('players') { + if ($self->{current_state} eq 'accept') { return "$self->{state_data}->{players}->[0]->{name} has challenged $self->{state_data}->{players}->[1]->{name}!"; } + elsif (@{$self->{state_data}->{players}} == 2) { return "$self->{state_data}->{players}->[0]->{name} is playing with $self->{state_data}->{players}->[1]->{name}!"; } + else { return "There are no players playing right now. Start a game with `connect4 challenge `!"; } } - } - if ($removed) { - if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { - $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 + when ('kick') { + if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { return "$nick: Sorry, only admins may kick people from the game."; } + + if (not length $arguments) { return "Usage: connect4 kick "; } + + my $removed = 0; + + for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { + if (lc $self->{state_data}->{players}->[$i]->{name} eq $arguments) { + splice @{$self->{state_data}->{players}}, $i--, 1; + $removed = 1; + } + } + + if ($removed) { + if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 } + return "/msg $self->{channel} $nick: $arguments has been kicked from the game."; + } else { + return "$nick: $arguments isn't even in the game."; + } } - return "/msg $self->{channel} $nick: $arguments has been kicked from the game."; - } else { - return "$nick: $arguments isn't even in the game."; - } - } - when ('play') { - if ($self->{debug}) { - $self->{pbot}->{logger}->log("Connect4: play state: $self->{current_state}\n" . Dumper $self->{state_data}); - } + when ('play') { + if ($self->{debug}) { $self->{pbot}->{logger}->log("Connect4: play state: $self->{current_state}\n" . Dumper $self->{state_data}); } - if ($self->{current_state} ne 'playermove') { - return "$nick: It's not time to do that now."; - } + if ($self->{current_state} ne 'playermove') { return "$nick: It's not time to do that now."; } - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - my $player; + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + my $player; - if ($self->{state_data}->{players}->[0]->{id} == $id) { - $player = 0; - } elsif ($self->{state_data}->{players}->[1]->{id} == $id) { - $player = 1; - } else { - return "You are not playing in this game."; - } + if ($self->{state_data}->{players}->[0]->{id} == $id) { $player = 0; } + elsif ($self->{state_data}->{players}->[1]->{id} == $id) { $player = 1; } + else { return "You are not playing in this game."; } - if ($self->{state_data}->{current_player} != $player) { - return "$nick: It is not your turn to attack!"; - } + if ($self->{state_data}->{current_player} != $player) { return "$nick: It is not your turn to attack!"; } - if ($self->{player}->[$player]->{done}) { - return "$nick: You have already played this turn."; - } + if ($self->{player}->[$player]->{done}) { return "$nick: You have already played this turn."; } - if ($arguments !~ m/^\d+$/) { - return "$nick: Usage: connect4 play ; must be in the [1, $self->{N_X}] range."; - } + if ($arguments !~ m/^\d+$/) { return "$nick: Usage: connect4 play ; must be in the [1, $self->{N_X}] range."; } - if ($self->play($player, uc $arguments)) { - if ($self->{player}->[$player]->{won}) { - $self->{previous_state} = $self->{current_state}; - $self->{current_state} = 'checkplayer'; - $self->run_one_state; - } else { - $self->{player}->[$player]->{done} = 1; - $self->{player}->[!$player]->{done} = 0; - $self->{state_data}->{current_player} = !$player; - $self->{state_data}->{ticks} = 1; - $self->{state_data}->{first_tock} = 1; - $self->{state_data}->{counter} = 0; + if ($self->play($player, uc $arguments)) { + if ($self->{player}->[$player]->{won}) { + $self->{previous_state} = $self->{current_state}; + $self->{current_state} = 'checkplayer'; + $self->run_one_state; + } else { + $self->{player}->[$player]->{done} = 1; + $self->{player}->[!$player]->{done} = 0; + $self->{state_data}->{current_player} = !$player; + $self->{state_data}->{ticks} = 1; + $self->{state_data}->{first_tock} = 1; + $self->{state_data}->{counter} = 0; + } + } } - } - } - when ('board') { - if ($self->{current_state} eq 'nogame' or $self->{current_state} eq 'accept' - or $self->{current_state} eq 'genboard' or $self->{current_state} eq 'gameover') { - return "$nick: There is no board to show right now."; - } + when ('board') { + if ($self->{current_state} eq 'nogame' or $self->{current_state} eq 'accept' or $self->{current_state} eq 'genboard' or $self->{current_state} eq 'gameover') { + return "$nick: There is no board to show right now."; + } - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - for (my $i = 0; $i < 2; $i++) { - if ($self->{state_data}->{players}->[$i]->{id} == $id) { - $self->send_message($self->{channel}, "$nick surveys the board!"); - $self->show_board; - return; + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); + for (my $i = 0; $i < 2; $i++) { + if ($self->{state_data}->{players}->[$i]->{id} == $id) { + $self->send_message($self->{channel}, "$nick surveys the board!"); + $self->show_board; + return; + } + } + + $self->show_board; } - } - $self->show_board; + default { return $usage; } } - default { - return $usage; - } - } - - return $result; + return $result; } sub connect4_timer { - my $self = shift; - $self->run_one_state; + my $self = shift; + $self->run_one_state; } sub player_left { - my ($self, $nick, $user, $host) = @_; + my ($self, $nick, $user, $host) = @_; - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); - my $removed = 0; - - for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { - if ($self->{state_data}->{players}->[$i]->{id} == $id) { - splice @{$self->{state_data}->{players}}, $i--, 1; - $self->send_message($self->{channel}, "$nick has left the game!"); - $removed = 1; - } - } - - if ($removed) { - if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { - $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 - } - return "/msg $self->{channel} $nick has left the game!"; - } -} - -sub send_message { - my ($self, $to, $text, $delay) = @_; - $delay = 0 if not defined $delay; - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - my $message = { - nick => $botnick, user => 'connect4', host => 'localhost', command => 'connect4 text', checkflood => 1, - message => $text - }; - $self->{pbot}->{interpreter}->add_message_to_output_queue($to, $message, $delay); -} - -sub run_one_state { - my $self = shift; - - # check for naughty or missing players - if ($self->{current_state} =~ /(?:move|accept)/) { + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account($nick, $user, $host); my $removed = 0; + for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { - if ($self->{state_data}->{players}->[$i]->{missedinputs} >= 3) { - $self->send_message($self->{channel}, "$color{red}$self->{state_data}->{players}->[$i]->{name} has missed too many prompts and has been ejected from the game!$color{reset}"); - splice @{$self->{state_data}->{players}}, $i--, 1; - $removed = 1; - } + if ($self->{state_data}->{players}->[$i]->{id} == $id) { + splice @{$self->{state_data}->{players}}, $i--, 1; + $self->send_message($self->{channel}, "$nick has left the game!"); + $removed = 1; + } } if ($removed) { - if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { - $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 - } + if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 } + return "/msg $self->{channel} $nick has left the game!"; + } +} + +sub send_message { + my ($self, $to, $text, $delay) = @_; + $delay = 0 if not defined $delay; + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + my $message = { + nick => $botnick, user => 'connect4', host => 'localhost', command => 'connect4 text', checkflood => 1, + message => $text + }; + $self->{pbot}->{interpreter}->add_message_to_output_queue($to, $message, $delay); +} + +sub run_one_state { + my $self = shift; + + # check for naughty or missing players + if ($self->{current_state} =~ /(?:move|accept)/) { + my $removed = 0; + for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { + if ($self->{state_data}->{players}->[$i]->{missedinputs} >= 3) { + $self->send_message( + $self->{channel}, + "$color{red}$self->{state_data}->{players}->[$i]->{name} has missed too many prompts and has been ejected from the game!$color{reset}" + ); + splice @{$self->{state_data}->{players}}, $i--, 1; + $removed = 1; + } + } + + if ($removed) { + if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 } + } + + if (not @{$self->{state_data}->{players}} == 2) { + $self->send_message($self->{channel}, "A player has left the game! The game is now over."); + $self->{current_state} = 'nogame'; + } } - if (not @{$self->{state_data}->{players}} == 2) { - $self->send_message($self->{channel}, "A player has left the game! The game is now over."); - $self->{current_state} = 'nogame'; - } - } + my $state_data = $self->{state_data}; - my $state_data = $self->{state_data}; - - # this shouldn't happen - if (not defined $self->{current_state}) { - $self->{pbot}->{logger}->log("Connect4 state broke.\n"); - $self->{current_state} = 'nogame'; - return; - } - - # transistioned to a brand new state; prepare first tock - if ($self->{previous_state} ne $self->{current_state}) { - $state_data->{newstate} = 1; - $state_data->{ticks} = 1; - - if (exists $state_data->{tick_drift}) { - $state_data->{ticks} += $state_data->{tick_drift}; - delete $state_data->{tick_drift}; + # this shouldn't happen + if (not defined $self->{current_state}) { + $self->{pbot}->{logger}->log("Connect4 state broke.\n"); + $self->{current_state} = 'nogame'; + return; } - $state_data->{first_tock} = 1; - $state_data->{counter} = 0; - } else { - $state_data->{newstate} = 0; - } + # transistioned to a brand new state; prepare first tock + if ($self->{previous_state} ne $self->{current_state}) { + $state_data->{newstate} = 1; + $state_data->{ticks} = 1; - # dump new state data for logging/debugging - if ($self->{debug} and $state_data->{newstate}) { - $self->{pbot}->{logger}->log("Connect4: New state: $self->{current_state}\n" . Dumper $state_data); - } + if (exists $state_data->{tick_drift}) { + $state_data->{ticks} += $state_data->{tick_drift}; + delete $state_data->{tick_drift}; + } - # run one state/tick - $state_data = $self->{states}{$self->{current_state}}{sub}($state_data); + $state_data->{first_tock} = 1; + $state_data->{counter} = 0; + } else { + $state_data->{newstate} = 0; + } - if ($state_data->{tocked}) { - delete $state_data->{tocked}; - delete $state_data->{first_tock}; - $state_data->{ticks} = 0; - } + # dump new state data for logging/debugging + if ($self->{debug} and $state_data->{newstate}) { $self->{pbot}->{logger}->log("Connect4: New state: $self->{current_state}\n" . Dumper $state_data); } - # transform to next state - $state_data->{previous_result} = $state_data->{result}; - $self->{previous_state} = $self->{current_state}; - $self->{current_state} = $self->{states}{$self->{current_state}}{trans}{$state_data->{result}}; - $self->{state_data} = $state_data; + # run one state/tick + $state_data = $self->{states}{$self->{current_state}}{sub}($state_data); - # next tick - $self->{state_data}->{ticks}++; + if ($state_data->{tocked}) { + delete $state_data->{tocked}; + delete $state_data->{first_tock}; + $state_data->{ticks} = 0; + } + + # transform to next state + $state_data->{previous_result} = $state_data->{result}; + $self->{previous_state} = $self->{current_state}; + $self->{current_state} = $self->{states}{$self->{current_state}}{trans}{$state_data->{result}}; + $self->{state_data} = $state_data; + + # next tick + $self->{state_data}->{ticks}++; } sub create_states { - my $self = shift; + my $self = shift; - $self->{pbot}->{logger}->log("Connect4: Creating game state machine\n"); + $self->{pbot}->{logger}->log("Connect4: Creating game state machine\n"); - $self->{previous_state} = ''; - $self->{current_state} = 'nogame'; - $self->{state_data} = { players => [], ticks => 0, newstate => 1 }; + $self->{previous_state} = ''; + $self->{current_state} = 'nogame'; + $self->{state_data} = {players => [], ticks => 0, newstate => 1}; - $self->{state_data}->{current_player} = 0; + $self->{state_data}->{current_player} = 0; - $self->{states}{'nogame'}{sub} = sub { $self->nogame(@_) }; - $self->{states}{'nogame'}{trans}{challenge} = 'accept'; - $self->{states}{'nogame'}{trans}{nogame} = 'nogame'; + $self->{states}{'nogame'}{sub} = sub { $self->nogame(@_) }; + $self->{states}{'nogame'}{trans}{challenge} = 'accept'; + $self->{states}{'nogame'}{trans}{nogame} = 'nogame'; - $self->{states}{'accept'}{sub} = sub { $self->accept(@_) }; - $self->{states}{'accept'}{trans}{stop} = 'nogame'; - $self->{states}{'accept'}{trans}{wait} = 'accept'; - $self->{states}{'accept'}{trans}{accept} = 'genboard'; + $self->{states}{'accept'}{sub} = sub { $self->accept(@_) }; + $self->{states}{'accept'}{trans}{stop} = 'nogame'; + $self->{states}{'accept'}{trans}{wait} = 'accept'; + $self->{states}{'accept'}{trans}{accept} = 'genboard'; - $self->{states}{'genboard'}{sub} = sub { $self->genboard(@_) }; - $self->{states}{'genboard'}{trans}{next} = 'showboard'; + $self->{states}{'genboard'}{sub} = sub { $self->genboard(@_) }; + $self->{states}{'genboard'}{trans}{next} = 'showboard'; - $self->{states}{'showboard'}{sub} = sub { $self->showboard(@_) }; - $self->{states}{'showboard'}{trans}{next} = 'playermove'; + $self->{states}{'showboard'}{sub} = sub { $self->showboard(@_) }; + $self->{states}{'showboard'}{trans}{next} = 'playermove'; - $self->{states}{'playermove'}{sub} = sub { $self->playermove(@_) }; - $self->{states}{'playermove'}{trans}{wait} = 'playermove'; - $self->{states}{'playermove'}{trans}{next} = 'checkplayer'; + $self->{states}{'playermove'}{sub} = sub { $self->playermove(@_) }; + $self->{states}{'playermove'}{trans}{wait} = 'playermove'; + $self->{states}{'playermove'}{trans}{next} = 'checkplayer'; - $self->{states}{'checkplayer'}{sub} = sub { $self->checkplayer(@_) }; - $self->{states}{'checkplayer'}{trans}{end} = 'gameover'; - $self->{states}{'checkplayer'}{trans}{next} = 'playermove'; + $self->{states}{'checkplayer'}{sub} = sub { $self->checkplayer(@_) }; + $self->{states}{'checkplayer'}{trans}{end} = 'gameover'; + $self->{states}{'checkplayer'}{trans}{next} = 'playermove'; - $self->{states}{'gameover'}{sub} = sub { $self->gameover(@_) }; - $self->{states}{'gameover'}{trans}{wait} = 'gameover'; - $self->{states}{'gameover'}{trans}{next} = 'nogame'; + $self->{states}{'gameover'}{sub} = sub { $self->gameover(@_) }; + $self->{states}{'gameover'}{trans}{wait} = 'gameover'; + $self->{states}{'gameover'}{trans}{next} = 'nogame'; } # connect4 stuff sub init_game { - my ($self, $nick1, $nick2) = @_; + my ($self, $nick1, $nick2) = @_; - $self->{chips} = 0; - $self->{draw} = 0; + $self->{chips} = 0; + $self->{draw} = 0; - $self->{board} = []; - $self->{winner_line} = []; + $self->{board} = []; + $self->{winner_line} = []; - $self->{player} = [ - { nick => $nick1, done => 0 }, - { nick => $nick2, done => 0 } - ]; + $self->{player} = [ + {nick => $nick1, done => 0}, + {nick => $nick2, done => 0} + ]; - $self->{turn} = 0; - $self->{horiz} = 0; + $self->{turn} = 0; + $self->{horiz} = 0; - $self->generate_board; + $self->generate_board; } sub generate_board { - my ($self) = @_; - my ($x, $y); + my ($self) = @_; + my ($x, $y); - for ($y = 0; $y < $self->{N_Y}; $y++) { - for ($x = 0; $x < $self->{N_X}; $x++) { - $self->{board}->[$y][$x] = ' '; + for ($y = 0; $y < $self->{N_Y}; $y++) { + for ($x = 0; $x < $self->{N_X}; $x++) { $self->{board}->[$y][$x] = ' '; } } - } } sub check_one { - my ($self, $y, $x, $prev) = @_; - my $chip = $self->{board}[$y][$x]; + my ($self, $y, $x, $prev) = @_; + my $chip = $self->{board}[$y][$x]; - push @{$self->{winner_line}}, "$y $x"; + push @{$self->{winner_line}}, "$y $x"; - if ($chip eq ' ' || $chip ne $prev) { - $self->{winner_line} = ($chip eq ' ') ? [] : [ "$y $x" ]; - } + if ($chip eq ' ' || $chip ne $prev) { $self->{winner_line} = ($chip eq ' ') ? [] : ["$y $x"]; } - return (scalar @{$self->{winner_line}} == $self->{CONNECTIONS}, $chip); + return (scalar @{$self->{winner_line}} == $self->{CONNECTIONS}, $chip); } sub connected { - my ($self) = @_; - my ($i, $j, $row, $col, $prev) = (0, 0, 0, 0, 0); - my $rv; + my ($self) = @_; + my ($i, $j, $row, $col, $prev) = (0, 0, 0, 0, 0); + my $rv; - for ($row = 0; $row < $self->{N_Y}; $row++) { - $prev = ' '; - $self->{winner_line} = []; - for ($i = $row, $j = $self->{N_X} - 1; $i < $self->{N_Y} && $j >= 0; $i++, $j--) { - ($rv, $prev) = $self->check_one($i, $j, $prev); - if ($rv) { - return 1; - } + for ($row = 0; $row < $self->{N_Y}; $row++) { + $prev = ' '; + $self->{winner_line} = []; + for ($i = $row, $j = $self->{N_X} - 1; $i < $self->{N_Y} && $j >= 0; $i++, $j--) { + ($rv, $prev) = $self->check_one($i, $j, $prev); + if ($rv) { return 1; } + } } - } - for ($col = $self->{N_X} - 1; $col >= 0; $col--) { - $prev = ' '; - $self->{winner_line} = []; - for ($i = 0, $j = $col; $i < $self->{N_Y} && $j >= 0; $i++, $j--) { - ($rv, $prev) = $self->check_one($i, $j, $prev); - if ($rv) { - return 2; - } + for ($col = $self->{N_X} - 1; $col >= 0; $col--) { + $prev = ' '; + $self->{winner_line} = []; + for ($i = 0, $j = $col; $i < $self->{N_Y} && $j >= 0; $i++, $j--) { + ($rv, $prev) = $self->check_one($i, $j, $prev); + if ($rv) { return 2; } + } } - } - for ($row = 0; $row < $self->{N_Y}; $row++) { - $prev = ' '; - $self->{winner_line} = []; - for ($i = $row, $j = 0; $i < $self->{N_Y}; $i++, $j++) { - ($rv, $prev) = $self->check_one($i, $j, $prev); - if ($rv) { - return 3; - } + for ($row = 0; $row < $self->{N_Y}; $row++) { + $prev = ' '; + $self->{winner_line} = []; + for ($i = $row, $j = 0; $i < $self->{N_Y}; $i++, $j++) { + ($rv, $prev) = $self->check_one($i, $j, $prev); + if ($rv) { return 3; } + } } - } - for ($col = 0; $col < $self->{N_X}; $col++) { - $prev = ' '; - $self->{winner_line} = []; - for ($i = 0, $j = $col; $i < $self->{N_Y} && $j < $self->{N_X}; $i++, $j++) { - ($rv, $prev) = $self->check_one($i, $j, $prev); - if ($rv) { - return 4; - } - } - } - - for ($row = 0; $row < $self->{N_Y}; $row++) { - $prev = ' '; - $self->{winner_line} = []; for ($col = 0; $col < $self->{N_X}; $col++) { - ($rv, $prev) = $self->check_one($row, $col, $prev); - if ($rv) { - return 5; - } + $prev = ' '; + $self->{winner_line} = []; + for ($i = 0, $j = $col; $i < $self->{N_Y} && $j < $self->{N_X}; $i++, $j++) { + ($rv, $prev) = $self->check_one($i, $j, $prev); + if ($rv) { return 4; } + } + } + + for ($row = 0; $row < $self->{N_Y}; $row++) { + $prev = ' '; + $self->{winner_line} = []; + for ($col = 0; $col < $self->{N_X}; $col++) { + ($rv, $prev) = $self->check_one($row, $col, $prev); + if ($rv) { return 5; } + } + } + + for ($col = 0; $col < $self->{N_X}; $col++) { + $prev = ' '; + $self->{winner_line} = []; + for ($row = $self->{N_Y} - 1; $row >= 0; $row--) { + ($rv, $prev) = $self->check_one($row, $col, $prev); + if ($rv) { return 6; } + } } - } - for ($col = 0; $col < $self->{N_X}; $col++) { - $prev = ' '; $self->{winner_line} = []; - for ($row = $self->{N_Y} - 1; $row >= 0; $row--) { - ($rv, $prev) = $self->check_one($row, $col, $prev); - if ($rv) { - return 6; - } - } - } - - $self->{winner_line} = []; - return 0; + return 0; } sub column_top { - my ($self, $x) = @_; - my $y; + my ($self, $x) = @_; + my $y; - for ($y = 0; $y < $self->{N_Y}; $y++) { - if ($self->{board}->[$y][$x] ne ' ') { - return $y - 1; + for ($y = 0; $y < $self->{N_Y}; $y++) { + if ($self->{board}->[$y][$x] ne ' ') { return $y - 1; } } - } - return -1; # shouldnt happen + return -1; # shouldnt happen } sub play { - my ($self, $player, $location) = @_; - my ($draw, $c4, $x, $y); + my ($self, $player, $location) = @_; + my ($draw, $c4, $x, $y); - $x = $location - 1; + $x = $location - 1; - $self->{pbot}->{logger}->log("play player $player: $x\n"); + $self->{pbot}->{logger}->log("play player $player: $x\n"); - if ($x < 0 || $x >= $self->{N_X} || $self->{board}[0][$x] ne ' ') { - $self->send_message($self->{channel}, "Target illegal/out of range, try again."); - return 0; - } + if ($x < 0 || $x >= $self->{N_X} || $self->{board}[0][$x] ne ' ') { + $self->send_message($self->{channel}, "Target illegal/out of range, try again."); + return 0; + } - $y = $self->column_top($x); + $y = $self->column_top($x); - $self->{board}->[$y][$x] = $player ? 'O' : 'X'; - $self->{chips}++; + $self->{board}->[$y][$x] = $player ? 'O' : 'X'; + $self->{chips}++; - $c4 = $self->connected; - $draw = $self->{chips} == $self->{N_X} * $self->{N_Y}; + $c4 = $self->connected; + $draw = $self->{chips} == $self->{N_X} * $self->{N_Y}; - my $nick1 = $self->{player}->[$player]->{nick}; - my $nick2 = $self->{player}->[$player ? 0 : 1]->{nick}; + my $nick1 = $self->{player}->[$player]->{nick}; + my $nick2 = $self->{player}->[$player ? 0 : 1]->{nick}; - $self->send_message($self->{channel}, "$nick1 placed piece at column: $location"); + $self->send_message($self->{channel}, "$nick1 placed piece at column: $location"); - if ($c4) { - $self->send_message($self->{channel}, "$nick1 connected $self->{CONNECTIONS} pieces! $color{red}--- VICTORY! --- $color{reset}"); - $self->{player}->[$player]->{won} = 1; - } elsif ($draw) { - $self->send_message($self->{channel}, "$color{red}--- DRAW! --- $color{reset}"); - $self->{draw} = 1; - } + if ($c4) { + $self->send_message($self->{channel}, "$nick1 connected $self->{CONNECTIONS} pieces! $color{red}--- VICTORY! --- $color{reset}"); + $self->{player}->[$player]->{won} = 1; + } elsif ($draw) { + $self->send_message($self->{channel}, "$color{red}--- DRAW! --- $color{reset}"); + $self->{draw} = 1; + } - return 1; + return 1; } sub show_board { - my ($self) = @_; - my ($x, $y, $buf, $chip, $c); + my ($self) = @_; + my ($x, $y, $buf, $chip, $c); - $self->{pbot}->{logger}->log("showing board\n"); + $self->{pbot}->{logger}->log("showing board\n"); - my $nick1 = $self->{player}->[0]->{nick}; - my $nick2 = $self->{player}->[1]->{nick}; + my $nick1 = $self->{player}->[0]->{nick}; + my $nick2 = $self->{player}->[1]->{nick}; - $buf = sprintf("%s: %s ", $nick1, "$color{yellow}X$color{reset}"); - $buf .= sprintf("%s: %s\n", $nick2, "$color{red}O$color{reset}"); + $buf = sprintf("%s: %s ", $nick1, "$color{yellow}X$color{reset}"); + $buf .= sprintf("%s: %s\n", $nick2, "$color{red}O$color{reset}"); - $buf .= "$color{bold}"; + $buf .= "$color{bold}"; - for($x = 1; $x < $self->{N_X} + 1; $x++) { - if ($x % 10 == 0) { - $buf .= $color{yellow}; - $buf .= ' '; - $buf .= $x % 10; - $buf .= ' '; - $buf .= $color{reset} . $color{bold}; - } else { - $buf .= " " . $x % 10 . " "; - } - } - - $buf .= "\n"; - - for ($y = 0; $y < $self->{N_Y}; $y++) { - for ($x = 0; $x < $self->{N_X}; $x++) { - $chip = $self->{board}->[$y][$x]; - my $rc = "$y $x"; - - $c = $chip eq 'O' ? $color{red} : $color{yellow}; - if (grep(/^$rc$/, @{$self->{winner_line}})) { - $c .= $color{bold}; - } - - $buf .= $color{blue} . "["; - $buf .= $c . $chip . $color{reset}; - $buf .= $color{blue} . "]"; + for ($x = 1; $x < $self->{N_X} + 1; $x++) { + if ($x % 10 == 0) { + $buf .= $color{yellow}; + $buf .= ' '; + $buf .= $x % 10; + $buf .= ' '; + $buf .= $color{reset} . $color{bold}; + } else { + $buf .= " " . $x % 10 . " "; + } } - $buf .= $color{reset}; $buf .= "\n"; - } - foreach my $line (split /\n/, $buf) { - $self->send_message($self->{channel}, $line); - } + for ($y = 0; $y < $self->{N_Y}; $y++) { + for ($x = 0; $x < $self->{N_X}; $x++) { + $chip = $self->{board}->[$y][$x]; + my $rc = "$y $x"; + + $c = $chip eq 'O' ? $color{red} : $color{yellow}; + if (grep(/^$rc$/, @{$self->{winner_line}})) { $c .= $color{bold}; } + + $buf .= $color{blue} . "["; + $buf .= $c . $chip . $color{reset}; + $buf .= $color{blue} . "]"; + } + + $buf .= $color{reset}; + $buf .= "\n"; + } + + foreach my $line (split /\n/, $buf) { $self->send_message($self->{channel}, $line); } } # state subroutines sub nogame { - my ($self, $state) = @_; - $state->{result} = 'nogame'; - return $state; + my ($self, $state) = @_; + $state->{result} = 'nogame'; + return $state; } sub accept { - my ($self, $state) = @_; + my ($self, $state) = @_; - $state->{max_count} = 3; + $state->{max_count} = 3; - if ($state->{players}->[1]->{accepted}) { - $state->{result} = 'accept'; + if ($state->{players}->[1]->{accepted}) { + $state->{result} = 'accept'; + return $state; + } + + my $tock = 15; + + if ($state->{ticks} % $tock == 0) { + $state->{tocked} = 1; + + if (++$state->{counter} > $state->{max_count}) { + if ($state->{players}->[1]->{id} == -1) { $self->send_message($self->{channel}, "Nobody has accepted $state->{players}->[0]->{name}'s challenge."); } + else { $self->send_message($self->{channel}, "$state->{players}->[1]->{name} has failed to accept $state->{players}->[0]->{name}'s challenge."); } + $state->{result} = 'stop'; + $state->{players} = []; + return $state; + } + + if ($state->{players}->[1]->{id} == -1) { + $self->send_message($self->{channel}, "$state->{players}->[0]->{name} has made an open challenge! Use `accept` to accept their challenge."); + } else { + $self->send_message($self->{channel}, "$state->{players}->[1]->{name}: $state->{players}->[0]->{name} has challenged you! Use `accept` to accept their challenge."); + } + } + + $state->{result} = 'wait'; return $state; - } - - my $tock = 15; - - if ($state->{ticks} % $tock == 0) { - $state->{tocked} = 1; - - if (++$state->{counter} > $state->{max_count}) { - if ($state->{players}->[1]->{id} == -1) { - $self->send_message($self->{channel}, "Nobody has accepted $state->{players}->[0]->{name}'s challenge."); - } else { - $self->send_message($self->{channel}, "$state->{players}->[1]->{name} has failed to accept $state->{players}->[0]->{name}'s challenge."); - } - $state->{result} = 'stop'; - $state->{players} = []; - return $state; - } - - if ($state->{players}->[1]->{id} == -1) { - $self->send_message($self->{channel}, "$state->{players}->[0]->{name} has made an open challenge! Use `accept` to accept their challenge."); - } else { - $self->send_message($self->{channel}, "$state->{players}->[1]->{name}: $state->{players}->[0]->{name} has challenged you! Use `accept` to accept their challenge."); - } - } - - $state->{result} = 'wait'; - return $state; } sub genboard { - my ($self, $state) = @_; - $self->init_game($state->{players}->[0]->{name}, $state->{players}->[1]->{name}); - $state->{max_count} = 3; - $state->{result} = 'next'; - return $state; + my ($self, $state) = @_; + $self->init_game($state->{players}->[0]->{name}, $state->{players}->[1]->{name}); + $state->{max_count} = 3; + $state->{result} = 'next'; + return $state; } sub showboard { - my ($self, $state) = @_; - $self->send_message($self->{channel}, "Showing board ..."); - $self->show_board; - $self->send_message($self->{channel}, "Fight! Anybody (players and spectators) can use `board` at any time to see latest version of the board!"); - $state->{result} = 'next'; - return $state; + my ($self, $state) = @_; + $self->send_message($self->{channel}, "Showing board ..."); + $self->show_board; + $self->send_message($self->{channel}, "Fight! Anybody (players and spectators) can use `board` at any time to see latest version of the board!"); + $state->{result} = 'next'; + return $state; } sub playermove { - my ($self, $state) = @_; + my ($self, $state) = @_; - my $tock; - if ($state->{first_tock}) { - $tock = 3; - } else { - $tock = 15; - } + my $tock; + if ($state->{first_tock}) { $tock = 3; } + else { $tock = 15; } - if ($self->{player}->[$state->{current_player}]->{done}) { - $self->{pbot}->{logger}->log("playermove: player $state->{current_player} done, nexting\n"); - $state->{result} = 'next'; - return $state; - } - - if ($state->{ticks} % $tock == 0) { - $state->{tocked} = 1; - if (++$state->{counter} > $state->{max_count}) { - $state->{players}->[$state->{current_player}]->{missedinputs}++; - $self->send_message($self->{channel}, "$state->{players}->[$state->{current_player}]->{name} failed to play in time. They forfeit their turn!"); - $self->{player}->[$state->{current_player}]->{done} = 1; - $self->{player}->[!$state->{current_player}]->{done} = 0; - $state->{current_player} = !$state->{current_player}; - $state->{result} = 'next'; - return $state; + if ($self->{player}->[$state->{current_player}]->{done}) { + $self->{pbot}->{logger}->log("playermove: player $state->{current_player} done, nexting\n"); + $state->{result} = 'next'; + return $state; } - my $red = $state->{counter} == $state->{max_count} ? $color{red} : ''; + if ($state->{ticks} % $tock == 0) { + $state->{tocked} = 1; + if (++$state->{counter} > $state->{max_count}) { + $state->{players}->[$state->{current_player}]->{missedinputs}++; + $self->send_message($self->{channel}, "$state->{players}->[$state->{current_player}]->{name} failed to play in time. They forfeit their turn!"); + $self->{player}->[$state->{current_player}]->{done} = 1; + $self->{player}->[!$state->{current_player}]->{done} = 0; + $state->{current_player} = !$state->{current_player}; + $state->{result} = 'next'; + return $state; + } - my $remaining = 15 * $state->{max_count}; - $remaining -= 15 * ($state->{counter} - 1); - $remaining = "(" . (concise duration $remaining) . " remaining)"; + my $red = $state->{counter} == $state->{max_count} ? $color{red} : ''; - $self->send_message($self->{channel}, "$state->{players}->[$state->{current_player}]->{name}: $red$remaining Play now via `play `!$color{reset}"); - } + my $remaining = 15 * $state->{max_count}; + $remaining -= 15 * ($state->{counter} - 1); + $remaining = "(" . (concise duration $remaining) . " remaining)"; - $state->{result} = 'wait'; - return $state; + $self->send_message($self->{channel}, "$state->{players}->[$state->{current_player}]->{name}: $red$remaining Play now via `play `!$color{reset}"); + } + + $state->{result} = 'wait'; + return $state; } sub checkplayer { - my ($self, $state) = @_; + my ($self, $state) = @_; - if ($self->{player}->[$state->{current_player}]->{won} || $self->{draw}) { - $state->{result} = 'end'; - } else { - $state->{result} = 'next'; - } - return $state; + if ($self->{player}->[$state->{current_player}]->{won} || $self->{draw}) { $state->{result} = 'end'; } + else { $state->{result} = 'next'; } + return $state; } sub gameover { - my ($self, $state) = @_; - my $buf; - if ($state->{ticks} % 2 == 0) { - $self->show_board; - $self->send_message($self->{channel}, $buf); - $self->send_message($self->{channel}, "Game over!"); - $state->{players} = []; - $state->{counter} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + my ($self, $state) = @_; + my $buf; + if ($state->{ticks} % 2 == 0) { + $self->show_board; + $self->send_message($self->{channel}, $buf); + $self->send_message($self->{channel}, "Game over!"); + $state->{players} = []; + $state->{counter} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } 1; diff --git a/Plugins/Counter.pm b/Plugins/Counter.pm index 302c96e0..83d95577 100644 --- a/Plugins/Counter.pm +++ b/Plugins/Counter.pm @@ -16,40 +16,41 @@ use Time::Duration qw/duration/; use Time::HiRes qw/gettimeofday/; sub initialize { - my ($self, %conf) = @_; - $self->{pbot}->{commands}->register(sub { $self->counteradd(@_) }, 'counteradd', 0); - $self->{pbot}->{commands}->register(sub { $self->counterdel(@_) }, 'counterdel', 0); - $self->{pbot}->{commands}->register(sub { $self->counterreset(@_) }, 'counterreset', 0); - $self->{pbot}->{commands}->register(sub { $self->countershow(@_) }, 'countershow', 0); - $self->{pbot}->{commands}->register(sub { $self->counterlist(@_) }, 'counterlist', 0); - $self->{pbot}->{commands}->register(sub { $self->countertrigger(@_) }, 'countertrigger', 1); - $self->{pbot}->{capabilities}->add('admin', 'can-countertrigger', 1); + my ($self, %conf) = @_; + $self->{pbot}->{commands}->register(sub { $self->counteradd(@_) }, 'counteradd', 0); + $self->{pbot}->{commands}->register(sub { $self->counterdel(@_) }, 'counterdel', 0); + $self->{pbot}->{commands}->register(sub { $self->counterreset(@_) }, 'counterreset', 0); + $self->{pbot}->{commands}->register(sub { $self->countershow(@_) }, 'countershow', 0); + $self->{pbot}->{commands}->register(sub { $self->counterlist(@_) }, 'counterlist', 0); + $self->{pbot}->{commands}->register(sub { $self->countertrigger(@_) }, 'countertrigger', 1); + $self->{pbot}->{capabilities}->add('admin', 'can-countertrigger', 1); - $self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) }); + $self->{pbot}->{event_dispatcher}->register_handler('irc.public', sub { $self->on_public(@_) }); - $self->{filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/counters.sqlite3'; - $self->create_database; + $self->{filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/counters.sqlite3'; + $self->create_database; } sub unload { - my $self = shift; - $self->{pbot}->{commands}->unregister('counteradd'); - $self->{pbot}->{commands}->unregister('counterdel'); - $self->{pbot}->{commands}->unregister('counterreset'); - $self->{pbot}->{commands}->unregister('countershow'); - $self->{pbot}->{commands}->unregister('counterlist'); - $self->{pbot}->{commands}->unregister('countertrigger'); - $self->{pbot}->{capabilities}->remove('can-countertrigger'); - $self->{pbot}->{event_dispatcher}->remove_handler('irc.public'); + my $self = shift; + $self->{pbot}->{commands}->unregister('counteradd'); + $self->{pbot}->{commands}->unregister('counterdel'); + $self->{pbot}->{commands}->unregister('counterreset'); + $self->{pbot}->{commands}->unregister('countershow'); + $self->{pbot}->{commands}->unregister('counterlist'); + $self->{pbot}->{commands}->unregister('countertrigger'); + $self->{pbot}->{capabilities}->remove('can-countertrigger'); + $self->{pbot}->{event_dispatcher}->remove_handler('irc.public'); } sub create_database { - my $self = shift; + my $self = shift; - eval { - $self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", { RaiseError => 1, PrintError => 0, AutoInactiveDestroy => 1, sqlite_unicode => 1 }) or die $DBI::errstr; + eval { + $self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", {RaiseError => 1, PrintError => 0, AutoInactiveDestroy => 1, sqlite_unicode => 1}) + or die $DBI::errstr; - $self->{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->do(<{dbh}->disconnect; - }; + $self->{dbh}->disconnect; + }; - $self->{pbot}->{logger}->log("Counter create database failed: $@") if $@; + $self->{pbot}->{logger}->log("Counter 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 }) or die $DBI::errstr; - }; + my ($self) = @_; + eval { $self->{dbh} = DBI->connect("dbi:SQLite:dbname=$self->{filename}", "", "", {RaiseError => 1, PrintError => 0, AutoInactiveDestroy => 1}) or die $DBI::errstr; }; - if ($@) { - $self->{pbot}->{logger}->log("Error opening Counters database: $@"); - return 0; - } else { - return 1; - } + if ($@) { + $self->{pbot}->{logger}->log("Error opening Counters database: $@"); + return 0; + } else { + return 1; + } } sub dbi_end { - my ($self) = @_; - $self->{dbh}->disconnect; + my ($self) = @_; + $self->{dbh}->disconnect; } sub add_counter { - my ($self, $owner, $channel, $name, $description) = @_; + my ($self, $owner, $channel, $name, $description) = @_; - my ($desc, $timestamp) = $self->get_counter($channel, $name); - if (defined $desc) { - return 0; - } + my ($desc, $timestamp) = $self->get_counter($channel, $name); + if (defined $desc) { return 0; } - eval { - my $sth = $self->{dbh}->prepare('INSERT INTO Counters (channel, name, description, timestamp, created_on, created_by, counter) VALUES (?, ?, ?, ?, ?, ?, ?)'); - $sth->bind_param(1, lc $channel); - $sth->bind_param(2, lc $name); - $sth->bind_param(3, $description); - $sth->bind_param(4, scalar gettimeofday); - $sth->bind_param(5, scalar gettimeofday); - $sth->bind_param(6, $owner); - $sth->bind_param(7, 0); - $sth->execute(); - }; - - if ($@) { - $self->{pbot}->{logger}->log("Add counter failed: $@"); - return 0; - } - return 1; -} - -sub reset_counter { - my ($self, $channel, $name) = @_; - - my ($description, $timestamp, $counter) = $self->get_counter($channel, $name); - if (not defined $description) { - return (undef, undef); - } - - eval { - my $sth = $self->{dbh}->prepare('UPDATE Counters SET timestamp = ?, counter = ? WHERE channel = ? AND name = ?'); - $sth->bind_param(1, scalar gettimeofday); - $sth->bind_param(2, ++$counter); - $sth->bind_param(3, lc $channel); - $sth->bind_param(4, lc $name); - $sth->execute(); - }; - - if ($@) { - $self->{pbot}->{logger}->log("Reset counter failed: $@"); - return (undef, undef); - } - return ($description, $timestamp); -} - -sub delete_counter { - my ($self, $channel, $name) = @_; - - my ($description, $timestamp) = $self->get_counter($channel, $name); - if (not defined $description) { - return 0; - } - - eval { - my $sth = $self->{dbh}->prepare('DELETE FROM Counters WHERE channel = ? AND name = ?'); - $sth->bind_param(1, lc $channel); - $sth->bind_param(2, lc $name); - $sth->execute(); - }; - - - if ($@) { - $self->{pbot}->{logger}->log("Delete counter failed: $@"); - return 0; - } - return 1; -} - -sub list_counters { - my ($self, $channel) = @_; - - my $counters = eval { - my $sth = $self->{dbh}->prepare('SELECT name FROM Counters WHERE channel = ?'); - $sth->bind_param(1, lc $channel); - $sth->execute(); - return $sth->fetchall_arrayref(); - }; - - if ($@) { - $self->{pbot}->{logger}->log("List counters failed: $@"); - } - return map { $_->[0] } @$counters; -} - -sub get_counter { - my ($self, $channel, $name) = @_; - - my ($description, $time, $counter, $created_on, $created_by) = eval { - my $sth = $self->{dbh}->prepare('SELECT description, timestamp, counter, created_on, created_by FROM Counters WHERE channel = ? AND name = ?'); - $sth->bind_param(1, lc $channel); - $sth->bind_param(2, lc $name); - $sth->execute(); - my $row = $sth->fetchrow_hashref(); - return ($row->{description}, $row->{timestamp}, $row->{counter}, $row->{created_on}, $row->{created_by}); - }; - - if ($@) { - $self->{pbot}->{logger}->log("Get counter failed: $@"); - return undef; - } - return ($description, $time, $counter, $created_on, $created_by); -} - -sub add_trigger { - my ($self, $channel, $trigger, $target) = @_; - - my $exists = $self->get_trigger($channel, $trigger); - if (defined $exists) { - return 0; - } - - eval { - my $sth = $self->{dbh}->prepare('INSERT INTO Triggers (channel, trigger, target) VALUES (?, ?, ?)'); - $sth->bind_param(1, lc $channel); - $sth->bind_param(2, lc $trigger); - $sth->bind_param(3, lc $target); - $sth->execute(); - }; - - if ($@) { - $self->{pbot}->{logger}->log("Add trigger failed: $@"); - return 0; - } - return 1; -} - -sub delete_trigger { - my ($self, $channel, $trigger) = @_; - - my $target = $self->get_trigger($channel, $trigger); - if (not defined $target) { - return 0; - } - - my $sth = $self->{dbh}->prepare('DELETE FROM Triggers WHERE channel = ? AND trigger = ?'); - $sth->bind_param(1, lc $channel); - $sth->bind_param(2, lc $trigger); - $sth->execute(); - return 1; -} - -sub list_triggers { - my ($self, $channel) = @_; - - my $triggers = eval { - my $sth = $self->{dbh}->prepare('SELECT trigger, target FROM Triggers WHERE channel = ?'); - $sth->bind_param(1, lc $channel); - $sth->execute(); - return $sth->fetchall_arrayref({}); - }; - - if ($@) { - $self->{pbot}->{logger}->log("List triggers failed: $@"); - } - return @$triggers; -} - -sub get_trigger { - my ($self, $channel, $trigger) = @_; - - my $target = eval { - my $sth = $self->{dbh}->prepare('SELECT target FROM Triggers WHERE channel = ? AND trigger = ?'); - $sth->bind_param(1, lc $channel); - $sth->bind_param(2, lc $trigger); - $sth->execute(); - my $row = $sth->fetchrow_hashref(); - return $row->{target}; - }; - - if ($@) { - $self->{pbot}->{logger}->log("Get trigger failed: $@"); - return undef; - } - return $target; -} - -sub counteradd { - my ($self, $from, $nick, $user, $host, $arguments) = @_; - return "Internal error." if not $self->dbi_begin; - my ($channel, $name, $description); - - if ($from !~ m/^#/) { - ($channel, $name, $description) = split /\s+/, $arguments, 3; - if (not defined $channel or not defined $name or not defined $description or $channel !~ m/^#/) { - return "Usage from private message: counteradd "; - } - } else { - $channel = $from; - ($name, $description) = split /\s+/, $arguments, 2; - if (not defined $name or not defined $description) { - return "Usage: counteradd "; - } - } - - my $result; - if ($self->add_counter("$nick!$user\@$host", $channel, $name, $description)) { - $result = "Counter added."; - } else { - $result = "Counter '$name' already exists."; - } - $self->dbi_end; - return $result; -} - -sub counterdel { - my ($self, $from, $nick, $user, $host, $arguments) = @_; - return "Internal error." if not $self->dbi_begin; - my ($channel, $name); - - if ($from !~ m/^#/) { - ($channel, $name) = split /\s+/, $arguments, 2; - if (not defined $channel or not defined $name or $channel !~ m/^#/) { - return "Usage from private message: counterdel "; - } - } else { - $channel = $from; - ($name) = split /\s+/, $arguments, 1; - if (not defined $name) { - return "Usage: counterdel "; - } - } - - my $result; - if ($self->delete_counter($channel, $name)) { - $result = "Counter removed."; - } else { - $result = "No such counter."; - } - $self->dbi_end; - return $result; -} - -sub counterreset { - my ($self, $from, $nick, $user, $host, $arguments) = @_; - return "Internal error." if not $self->dbi_begin; - my ($channel, $name); - - if ($from !~ m/^#/) { - ($channel, $name) = split /\s+/, $arguments, 2; - if (not defined $channel or not defined $name or $channel !~ m/^#/) { - return "Usage from private message: counterreset "; - } - } else { - $channel = $from; - ($name) = split /\s+/, $arguments, 1; - if (not defined $name) { - return "Usage: counterreset "; - } - } - - my $result; - my ($description, $timestamp) = $self->reset_counter($channel, $name); - if (defined $description) { - my $ago = duration gettimeofday - $timestamp; - $result = "It had been $ago since $description."; - } else { - $result = "No such counter."; - } - - $self->dbi_end; - return $result; -} - -sub countershow { - my ($self, $from, $nick, $user, $host, $arguments) = @_; - return "Internal error." if not $self->dbi_begin; - my ($channel, $name); - - if ($from !~ m/^#/) { - ($channel, $name) = split /\s+/, $arguments, 2; - if (not defined $channel or not defined $name or $channel !~ m/^#/) { - return "Usage from private message: countershow "; - } - } else { - $channel = $from; - ($name) = split /\s+/, $arguments, 1; - if (not defined $name) { - return "Usage: countershow "; - } - } - - my $result; - my ($description, $timestamp, $counter, $created_on) = $self->get_counter($channel, $name); - if (defined $description) { - my $ago = duration gettimeofday - $timestamp; - $created_on = duration gettimeofday - $created_on; - $result = "It has been $ago since $description. It has been reset $counter time" . ($counter == 1 ? '' : 's') . " since its creation $created_on ago."; - } else { - $result = "No such counter."; - } - - $self->dbi_end; - return $result; -} - -sub counterlist { - my ($self, $from, $nick, $user, $host, $arguments) = @_; - return "Internal error." if not $self->dbi_begin; - my $channel; - - if ($from !~ m/^#/) { - if (not length $arguments or $arguments !~ m/^#/) { - return "Usage from private message: counterlist "; - } - $channel = $arguments; - } else { - $channel = $from; - } - - my @counters = $self->list_counters($channel); - - my $result; - if (not @counters) { - $result = "No counters available for $channel."; - } else { - my $comma = ''; - $result = "Counters for $channel: "; - foreach my $counter (sort @counters) { - $result .= "$comma$counter"; - $comma = ', '; - } - } - - $self->dbi_end; - return $result; -} - -sub countertrigger { - my ($self, $from, $nick, $user, $host, $arguments) = @_; - return "Internal error." if not $self->dbi_begin; - my $command; - ($command, $arguments) = split / /, $arguments, 2; - - my ($channel, $result); - - given ($command) { - when ('list') { - if ($from =~ m/^#/) { - $channel = $from; - } else { - ($channel) = split / /, $arguments, 1; - if ($channel !~ m/^#/) { - $self->dbi_end; - return "Usage from private message: countertrigger list "; - } - } - - my @triggers = $self->list_triggers($channel); - - if (not @triggers) { - $result = "No counter triggers set for $channel."; - } else { - $result = "Triggers for $channel: "; - my $comma = ''; - foreach my $trigger (@triggers) { - $result .= "$comma$trigger->{trigger} -> $trigger->{target}"; - $comma = ', '; - } - } - } - - when ('add') { - if ($from =~ m/^#/) { - $channel = $from; - } else { - ($channel, $arguments) = split / /, $arguments, 2; - if ($channel !~ m/^#/) { - $self->dbi_end; - return "Usage from private message: countertrigger add "; - } - } - - - my ($trigger, $target) = split / /, $arguments, 2; - - if (not defined $trigger or not defined $target) { - if ($from !~ m/^#/) { - $result = "Usage from private message: countertrigger add "; - } else { - $result = "Usage: countertrigger add "; - } - $self->dbi_end; - return $result; - } - - my $exists = $self->get_trigger($channel, $trigger); - - if (defined $exists) { - $self->dbi_end; - return "Trigger already exists."; - } - - if ($self->add_trigger($channel, $trigger, $target)) { - $result = "Trigger added."; - } else { - $result = "Failed to add trigger."; - } - } - - when ('delete') { - if ($from =~ m/^#/) { - $channel = $from; - } else { - ($channel, $arguments) = split / /, $arguments, 2; - if ($channel !~ m/^#/) { - $self->dbi_end; - return "Usage from private message: countertrigger delete "; - } - } - - my ($trigger) = split / /, $arguments, 1; - - if (not defined $trigger) { - if ($from !~ m/^#/) { - $result = "Usage from private message: countertrigger delete "; - } else { - $result = "Usage: countertrigger delete "; - } - $self->dbi_end; - return $result; - } - - my $target = $self->get_trigger($channel, $trigger); - - if (not defined $target) { - $result = "No such trigger."; - } else { - $self->delete_trigger($channel, $trigger); - $result = "Trigger deleted."; - } - } - - default { - $result = "Usage: countertrigger [arguments]"; - } - } - - $self->dbi_end; - return $result; -} - -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}; - - if ($self->{pbot}->{ignorelist}->check_ignore($nick, $user, $host, $channel, 1)) { - my $admin = $self->{pbot}->{users}->loggedin_admin($channel, "$nick!$user\@$host"); - if (!defined $admin || $admin->{level} < 10) { - return 0; - } - } - - if (not $self->dbi_begin) { - return 0; - } - - my @triggers = $self->list_triggers($channel); - - my $hostmask = "$nick!$user\@$host"; - - foreach my $trigger (@triggers) { eval { - my $message; - - if ($trigger->{trigger} =~ m/^\^/) { - $message = "$hostmask $msg"; - } else { - $message = $msg; - } - - my $silent = 0; - - if ($trigger->{trigger} =~ s/:silent$//i) { - $silent = 1; - } - - if ($message =~ m/$trigger->{trigger}/i) { - my ($desc, $timestamp) = $self->reset_counter($channel, $trigger->{target}); - - if (defined $desc) { - if (not $silent and gettimeofday - $timestamp >= 60 * 60) { - my $ago = duration gettimeofday - $timestamp; - $event->{conn}->privmsg($channel, "It had been $ago since $desc."); - } - } - } + my $sth = $self->{dbh}->prepare('INSERT INTO Counters (channel, name, description, timestamp, created_on, created_by, counter) VALUES (?, ?, ?, ?, ?, ?, ?)'); + $sth->bind_param(1, lc $channel); + $sth->bind_param(2, lc $name); + $sth->bind_param(3, $description); + $sth->bind_param(4, scalar gettimeofday); + $sth->bind_param(5, scalar gettimeofday); + $sth->bind_param(6, $owner); + $sth->bind_param(7, 0); + $sth->execute(); }; if ($@) { - $self->{pbot}->{logger}->log("Skipping bad trigger $trigger->{trigger}: $@"); + $self->{pbot}->{logger}->log("Add counter failed: $@"); + return 0; } - } - $self->dbi_end; - return 0; + return 1; +} + +sub reset_counter { + my ($self, $channel, $name) = @_; + + my ($description, $timestamp, $counter) = $self->get_counter($channel, $name); + if (not defined $description) { return (undef, undef); } + + eval { + my $sth = $self->{dbh}->prepare('UPDATE Counters SET timestamp = ?, counter = ? WHERE channel = ? AND name = ?'); + $sth->bind_param(1, scalar gettimeofday); + $sth->bind_param(2, ++$counter); + $sth->bind_param(3, lc $channel); + $sth->bind_param(4, lc $name); + $sth->execute(); + }; + + if ($@) { + $self->{pbot}->{logger}->log("Reset counter failed: $@"); + return (undef, undef); + } + return ($description, $timestamp); +} + +sub delete_counter { + my ($self, $channel, $name) = @_; + + my ($description, $timestamp) = $self->get_counter($channel, $name); + if (not defined $description) { return 0; } + + eval { + my $sth = $self->{dbh}->prepare('DELETE FROM Counters WHERE channel = ? AND name = ?'); + $sth->bind_param(1, lc $channel); + $sth->bind_param(2, lc $name); + $sth->execute(); + }; + + if ($@) { + $self->{pbot}->{logger}->log("Delete counter failed: $@"); + return 0; + } + return 1; +} + +sub list_counters { + my ($self, $channel) = @_; + + my $counters = eval { + my $sth = $self->{dbh}->prepare('SELECT name FROM Counters WHERE channel = ?'); + $sth->bind_param(1, lc $channel); + $sth->execute(); + return $sth->fetchall_arrayref(); + }; + + if ($@) { $self->{pbot}->{logger}->log("List counters failed: $@"); } + return map { $_->[0] } @$counters; +} + +sub get_counter { + my ($self, $channel, $name) = @_; + + my ($description, $time, $counter, $created_on, $created_by) = eval { + my $sth = $self->{dbh}->prepare('SELECT description, timestamp, counter, created_on, created_by FROM Counters WHERE channel = ? AND name = ?'); + $sth->bind_param(1, lc $channel); + $sth->bind_param(2, lc $name); + $sth->execute(); + my $row = $sth->fetchrow_hashref(); + return ($row->{description}, $row->{timestamp}, $row->{counter}, $row->{created_on}, $row->{created_by}); + }; + + if ($@) { + $self->{pbot}->{logger}->log("Get counter failed: $@"); + return undef; + } + return ($description, $time, $counter, $created_on, $created_by); +} + +sub add_trigger { + my ($self, $channel, $trigger, $target) = @_; + + my $exists = $self->get_trigger($channel, $trigger); + if (defined $exists) { return 0; } + + eval { + my $sth = $self->{dbh}->prepare('INSERT INTO Triggers (channel, trigger, target) VALUES (?, ?, ?)'); + $sth->bind_param(1, lc $channel); + $sth->bind_param(2, lc $trigger); + $sth->bind_param(3, lc $target); + $sth->execute(); + }; + + if ($@) { + $self->{pbot}->{logger}->log("Add trigger failed: $@"); + return 0; + } + return 1; +} + +sub delete_trigger { + my ($self, $channel, $trigger) = @_; + + my $target = $self->get_trigger($channel, $trigger); + if (not defined $target) { return 0; } + + my $sth = $self->{dbh}->prepare('DELETE FROM Triggers WHERE channel = ? AND trigger = ?'); + $sth->bind_param(1, lc $channel); + $sth->bind_param(2, lc $trigger); + $sth->execute(); + return 1; +} + +sub list_triggers { + my ($self, $channel) = @_; + + my $triggers = eval { + my $sth = $self->{dbh}->prepare('SELECT trigger, target FROM Triggers WHERE channel = ?'); + $sth->bind_param(1, lc $channel); + $sth->execute(); + return $sth->fetchall_arrayref({}); + }; + + if ($@) { $self->{pbot}->{logger}->log("List triggers failed: $@"); } + return @$triggers; +} + +sub get_trigger { + my ($self, $channel, $trigger) = @_; + + my $target = eval { + my $sth = $self->{dbh}->prepare('SELECT target FROM Triggers WHERE channel = ? AND trigger = ?'); + $sth->bind_param(1, lc $channel); + $sth->bind_param(2, lc $trigger); + $sth->execute(); + my $row = $sth->fetchrow_hashref(); + return $row->{target}; + }; + + if ($@) { + $self->{pbot}->{logger}->log("Get trigger failed: $@"); + return undef; + } + return $target; +} + +sub counteradd { + my ($self, $from, $nick, $user, $host, $arguments) = @_; + return "Internal error." if not $self->dbi_begin; + my ($channel, $name, $description); + + if ($from !~ m/^#/) { + ($channel, $name, $description) = split /\s+/, $arguments, 3; + if (not defined $channel or not defined $name or not defined $description or $channel !~ m/^#/) { + return "Usage from private message: counteradd "; + } + } else { + $channel = $from; + ($name, $description) = split /\s+/, $arguments, 2; + if (not defined $name or not defined $description) { return "Usage: counteradd "; } + } + + my $result; + if ($self->add_counter("$nick!$user\@$host", $channel, $name, $description)) { $result = "Counter added."; } + else { $result = "Counter '$name' already exists."; } + $self->dbi_end; + return $result; +} + +sub counterdel { + my ($self, $from, $nick, $user, $host, $arguments) = @_; + return "Internal error." if not $self->dbi_begin; + my ($channel, $name); + + if ($from !~ m/^#/) { + ($channel, $name) = split /\s+/, $arguments, 2; + if (not defined $channel or not defined $name or $channel !~ m/^#/) { return "Usage from private message: counterdel "; } + } else { + $channel = $from; + ($name) = split /\s+/, $arguments, 1; + if (not defined $name) { return "Usage: counterdel "; } + } + + my $result; + if ($self->delete_counter($channel, $name)) { $result = "Counter removed."; } + else { $result = "No such counter."; } + $self->dbi_end; + return $result; +} + +sub counterreset { + my ($self, $from, $nick, $user, $host, $arguments) = @_; + return "Internal error." if not $self->dbi_begin; + my ($channel, $name); + + if ($from !~ m/^#/) { + ($channel, $name) = split /\s+/, $arguments, 2; + if (not defined $channel or not defined $name or $channel !~ m/^#/) { return "Usage from private message: counterreset "; } + } else { + $channel = $from; + ($name) = split /\s+/, $arguments, 1; + if (not defined $name) { return "Usage: counterreset "; } + } + + my $result; + my ($description, $timestamp) = $self->reset_counter($channel, $name); + if (defined $description) { + my $ago = duration gettimeofday - $timestamp; + $result = "It had been $ago since $description."; + } else { + $result = "No such counter."; + } + + $self->dbi_end; + return $result; +} + +sub countershow { + my ($self, $from, $nick, $user, $host, $arguments) = @_; + return "Internal error." if not $self->dbi_begin; + my ($channel, $name); + + if ($from !~ m/^#/) { + ($channel, $name) = split /\s+/, $arguments, 2; + if (not defined $channel or not defined $name or $channel !~ m/^#/) { return "Usage from private message: countershow "; } + } else { + $channel = $from; + ($name) = split /\s+/, $arguments, 1; + if (not defined $name) { return "Usage: countershow "; } + } + + my $result; + my ($description, $timestamp, $counter, $created_on) = $self->get_counter($channel, $name); + if (defined $description) { + my $ago = duration gettimeofday - $timestamp; + $created_on = duration gettimeofday - $created_on; + $result = "It has been $ago since $description. It has been reset $counter time" . ($counter == 1 ? '' : 's') . " since its creation $created_on ago."; + } else { + $result = "No such counter."; + } + + $self->dbi_end; + return $result; +} + +sub counterlist { + my ($self, $from, $nick, $user, $host, $arguments) = @_; + return "Internal error." if not $self->dbi_begin; + my $channel; + + if ($from !~ m/^#/) { + if (not length $arguments or $arguments !~ m/^#/) { return "Usage from private message: counterlist "; } + $channel = $arguments; + } else { + $channel = $from; + } + + my @counters = $self->list_counters($channel); + + my $result; + if (not @counters) { $result = "No counters available for $channel."; } + else { + my $comma = ''; + $result = "Counters for $channel: "; + foreach my $counter (sort @counters) { + $result .= "$comma$counter"; + $comma = ', '; + } + } + + $self->dbi_end; + return $result; +} + +sub countertrigger { + my ($self, $from, $nick, $user, $host, $arguments) = @_; + return "Internal error." if not $self->dbi_begin; + my $command; + ($command, $arguments) = split / /, $arguments, 2; + + my ($channel, $result); + + given ($command) { + when ('list') { + if ($from =~ m/^#/) { $channel = $from; } + else { + ($channel) = split / /, $arguments, 1; + if ($channel !~ m/^#/) { + $self->dbi_end; + return "Usage from private message: countertrigger list "; + } + } + + my @triggers = $self->list_triggers($channel); + + if (not @triggers) { $result = "No counter triggers set for $channel."; } + else { + $result = "Triggers for $channel: "; + my $comma = ''; + foreach my $trigger (@triggers) { + $result .= "$comma$trigger->{trigger} -> $trigger->{target}"; + $comma = ', '; + } + } + } + + when ('add') { + if ($from =~ m/^#/) { $channel = $from; } + else { + ($channel, $arguments) = split / /, $arguments, 2; + if ($channel !~ m/^#/) { + $self->dbi_end; + return "Usage from private message: countertrigger add "; + } + } + + my ($trigger, $target) = split / /, $arguments, 2; + + if (not defined $trigger or not defined $target) { + if ($from !~ m/^#/) { $result = "Usage from private message: countertrigger add "; } + else { $result = "Usage: countertrigger add "; } + $self->dbi_end; + return $result; + } + + my $exists = $self->get_trigger($channel, $trigger); + + if (defined $exists) { + $self->dbi_end; + return "Trigger already exists."; + } + + if ($self->add_trigger($channel, $trigger, $target)) { $result = "Trigger added."; } + else { $result = "Failed to add trigger."; } + } + + when ('delete') { + if ($from =~ m/^#/) { $channel = $from; } + else { + ($channel, $arguments) = split / /, $arguments, 2; + if ($channel !~ m/^#/) { + $self->dbi_end; + return "Usage from private message: countertrigger delete "; + } + } + + my ($trigger) = split / /, $arguments, 1; + + if (not defined $trigger) { + if ($from !~ m/^#/) { $result = "Usage from private message: countertrigger delete "; } + else { $result = "Usage: countertrigger delete "; } + $self->dbi_end; + return $result; + } + + my $target = $self->get_trigger($channel, $trigger); + + if (not defined $target) { $result = "No such trigger."; } + else { + $self->delete_trigger($channel, $trigger); + $result = "Trigger deleted."; + } + } + + default { $result = "Usage: countertrigger [arguments]"; } + } + + $self->dbi_end; + return $result; +} + +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}; + + if ($self->{pbot}->{ignorelist}->check_ignore($nick, $user, $host, $channel, 1)) { + my $admin = $self->{pbot}->{users}->loggedin_admin($channel, "$nick!$user\@$host"); + if (!defined $admin || $admin->{level} < 10) { return 0; } + } + + if (not $self->dbi_begin) { return 0; } + + my @triggers = $self->list_triggers($channel); + + my $hostmask = "$nick!$user\@$host"; + + foreach my $trigger (@triggers) { + eval { + my $message; + + if ($trigger->{trigger} =~ m/^\^/) { $message = "$hostmask $msg"; } + else { $message = $msg; } + + my $silent = 0; + + if ($trigger->{trigger} =~ s/:silent$//i) { $silent = 1; } + + if ($message =~ m/$trigger->{trigger}/i) { + my ($desc, $timestamp) = $self->reset_counter($channel, $trigger->{target}); + + if (defined $desc) { + if (not $silent and gettimeofday - $timestamp >= 60 * 60) { + my $ago = duration gettimeofday - $timestamp; + $event->{conn}->privmsg($channel, "It had been $ago since $desc."); + } + } + } + }; + + if ($@) { $self->{pbot}->{logger}->log("Skipping bad trigger $trigger->{trigger}: $@"); } + } + $self->dbi_end; + return 0; } 1; diff --git a/Plugins/Date.pm b/Plugins/Date.pm index 6aa786ed..81f1c0fc 100644 --- a/Plugins/Date.pm +++ b/Plugins/Date.pm @@ -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 ] [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 ] [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; diff --git a/Plugins/Example.pm b/Plugins/Example.pm index a5a38a87..7f5eb7f1 100644 --- a/Plugins/Example.pm +++ b/Plugins/Example.pm @@ -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; diff --git a/Plugins/FuncBuiltins.pm b/Plugins/FuncBuiltins.pm index 9b0b53e0..cd7a0c9c 100644 --- a/Plugins/FuncBuiltins.pm +++ b/Plugins/FuncBuiltins.pm @@ -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 ', - subref => sub { $self->func_title(@_) } - } - ); - $self->{pbot}->{functions}->register( - 'ucfirst', - { - desc => 'Uppercases first character', - usage => 'ucfirst ', - subref => sub { $self->func_ucfirst(@_) } - } - ); - $self->{pbot}->{functions}->register( - 'uc', - { - desc => 'Uppercases all characters', - usage => 'uc ', - subref => sub { $self->func_uc(@_) } - } - ); - $self->{pbot}->{functions}->register( - 'lc', - { - desc => 'Lowercases all characters', - usage => 'lc ', - subref => sub { $self->func_lc(@_) } - } - ); - $self->{pbot}->{functions}->register( - 'unquote', - { - desc => 'removes unescaped surrounding quotes and strips escapes from escaped quotes', - usage => 'unquote ', - subref => sub { $self->func_unquote(@_) } - } - ); - $self->{pbot}->{functions}->register('uri_escape', - { - desc => 'percent-encode unsafe URI characters', - usage => 'uri_escape ', - subref => sub { $self->func_uri_escape(@_) } - } - ); + my ($self, %conf) = @_; + $self->{pbot}->{functions}->register( + 'title', + { + desc => 'Title-cases text', + usage => 'title ', + subref => sub { $self->func_title(@_) } + } + ); + $self->{pbot}->{functions}->register( + 'ucfirst', + { + desc => 'Uppercases first character', + usage => 'ucfirst ', + subref => sub { $self->func_ucfirst(@_) } + } + ); + $self->{pbot}->{functions}->register( + 'uc', + { + desc => 'Uppercases all characters', + usage => 'uc ', + subref => sub { $self->func_uc(@_) } + } + ); + $self->{pbot}->{functions}->register( + 'lc', + { + desc => 'Lowercases all characters', + usage => 'lc ', + subref => sub { $self->func_lc(@_) } + } + ); + $self->{pbot}->{functions}->register( + 'unquote', + { + desc => 'removes unescaped surrounding quotes and strips escapes from escaped quotes', + usage => 'unquote ', + subref => sub { $self->func_unquote(@_) } + } + ); + $self->{pbot}->{functions}->register( + 'uri_escape', + { + desc => 'percent-encode unsafe URI characters', + usage => 'uri_escape ', + 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/^"(.*?)(?{pbot}->{functions}->register( - 'sed', - { - desc => 'a sed-like stream editor', - usage => 'sed s///[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///[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(.)(.*?)(?{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; diff --git a/Plugins/MagicCommand.pm b/Plugins/MagicCommand.pm index 660aa9ae..1b6d67ed 100644 --- a/Plugins/MagicCommand.pm +++ b/Plugins/MagicCommand.pm @@ -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; diff --git a/Plugins/ParseDate.pm b/Plugins/ParseDate.pm index edb4c371..ab9c7376 100644 --- a/Plugins/ParseDate.pm +++ b/Plugins/ParseDate.pm @@ -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; diff --git a/Plugins/Plugin.pm b/Plugins/Plugin.pm index 4de9edb2..dc63d7b4 100644 --- a/Plugins/Plugin.pm +++ b/Plugins/Plugin.pm @@ -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; diff --git a/Plugins/Quotegrabs.pm b/Plugins/Quotegrabs.pm index b9340a3d..08b546cd 100644 --- a/Plugins/Quotegrabs.pm +++ b/Plugins/Quotegrabs.pm @@ -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 "\n\n"; - print FILE '' . "\n"; - print FILE '' . "\n"; - print FILE '' . "\n"; - print FILE "\nGenerated at $time

$botnick\'s Quotegrabs

\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 "\n\n"; + print FILE '' . "\n"; + print FILE '' . "\n"; + print FILE '' . "\n"; + print FILE "\nGenerated at $time

$botnick\'s Quotegrabs

\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 "" . encode_entities($quotegrab->{channel}) . "
\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 "
\n
ownercreated ontimes referencedfactoidlast edited byedited datelast referenced bylast referenced date
\n" if $had_table; - print FILE "\n"; - print FILE "

" . encode_entities($quotegrab->{channel}) . "

\n"; - print FILE "\n"; - print FILE "\n\n"; - print FILE "\n"; - print FILE "\n"; - print FILE "\n"; - print FILE "\n"; - print FILE "\n"; - print FILE "\n\n\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 "" . encode_entities($quotegrab->{channel}) . "
\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 "\n
id    author(s)quotedategrabbed by
\n" if $had_table; + print FILE "\n"; + print FILE "

" . encode_entities($quotegrab->{channel}) . "

\n"; + print FILE "\n"; + print FILE "\n\n"; + print FILE "\n"; + print FILE "\n"; + print FILE "\n"; + print FILE "\n"; + print FILE "\n"; + print FILE "\n\n\n"; + $had_table = 1; + $table_id++; + } - if ($i % 2) { - print FILE "\n"; - } else { - print FILE "\n"; + $last_channel = $quotegrab->{channel}; + $i++; + + if ($i % 2) { print FILE "\n"; } + else { print FILE "\n"; } + + print FILE ""; + + my @nicks = split /\+/, $quotegrab->{nick}; + $text = join ', ', uniq(@nicks); + print FILE ""; + + my $nick; + $text = $quotegrab->{text}; + + if ($text =~ s/^\/me\s+//) { $nick = "* $nicks[0]"; } + else { $nick = "<$nicks[0]>"; } + + $text = "\n"; + print FILE $text; + + print FILE "\n"; + print FILE "\n"; + print FILE "\n"; } - print FILE ""; - - my @nicks = split /\+/, $quotegrab->{nick}; - $text = join ', ', uniq(@nicks); - print FILE ""; - - my $nick; - $text = $quotegrab->{text}; - - if ($text =~ s/^\/me\s+//) { - $nick = "* $nicks[0]"; - } else { - $nick = "<$nicks[0]>"; - } - - $text = "\n"; - print FILE $text; - - - print FILE "\n"; - print FILE "\n"; - print FILE "\n"; - } - - print FILE "\n
id    author(s)quotedategrabbed by
" . ($quotegrab->{id}) . "" . encode_entities($text) . "" . encode_entities($nick) . " " . encode_entities($text) . "" . encode_entities(strftime "%Y/%m/%d %a %H:%M:%S", localtime $quotegrab->{timestamp}) . "" . encode_entities($quotegrab->{grabbed_by}) . "
" . ($quotegrab->{id}) . "" . encode_entities($text) . "". encode_entities($nick) . " " . encode_entities($text) . "" . encode_entities(strftime "%Y/%m/%d %a %H:%M:%S", localtime $quotegrab->{timestamp}) . "" . encode_entities($quotegrab->{grabbed_by}) . "
\n" if $had_table; - print FILE "\n"; - print FILE "\n\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 "\n"; + print FILE "\n\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 [history [channel]] [+ [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 [[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 [history [channel]] [+ [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 [[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 ] [-t ]'; - - 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 ] [-t ]'; - 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; diff --git a/Plugins/Quotegrabs/Quotegrabs_Hashtable.pm b/Plugins/Quotegrabs/Quotegrabs_Hashtable.pm index 96b4b64f..516cb8a0 100644 --- a/Plugins/Quotegrabs/Quotegrabs_Hashtable.pm +++ b/Plugins/Quotegrabs/Quotegrabs_Hashtable.pm @@ -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 = ; - close(FILE); + open(FILE, "< $filename") or die "Couldn't open $filename: $!\n"; + my @contents = ; + 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; diff --git a/Plugins/Quotegrabs/Quotegrabs_SQLite.pm b/Plugins/Quotegrabs/Quotegrabs_SQLite.pm index 2838e07b..fbcbb8fa 100644 --- a/Plugins/Quotegrabs/Quotegrabs_SQLite.pm +++ b/Plugins/Quotegrabs/Quotegrabs_SQLite.pm @@ -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; diff --git a/Plugins/RelayUnreg.pm b/Plugins/RelayUnreg.pm index 74053f28..32254452 100644 --- a/Plugins/RelayUnreg.pm +++ b/Plugins/RelayUnreg.pm @@ -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; diff --git a/Plugins/RemindMe.pm b/Plugins/RemindMe.pm index 94d2eff4..94f19b9f 100644 --- a/Plugins/RemindMe.pm +++ b/Plugins/RemindMe.pm @@ -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(<{dbh}->do(<{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/(? \$repeat, - 't:s' => \$alarm, - 'c:s' => \$target, - 'm:s' => \$text, - 'l:s' => \$list_reminders, - 'd:i' => \$delete_id); + $arguments =~ s/(? \$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; diff --git a/Plugins/RestrictedMod.pm b/Plugins/RestrictedMod.pm index e6ececa2..09004ecc 100644 --- a/Plugins/RestrictedMod.pm +++ b/Plugins/RestrictedMod.pm @@ -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 ; 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 " }, - 'ban' => { subref => sub { $self->ban(@_) }, help => "Bans a nick from the channel. Cannot be used to set a custom banmask. Usage: mod ban " }, - 'mute' => { subref => sub { $self->mute(@_) }, help => "Mutes a nick in the channel. Usage: mod mute " }, - 'unban' => { subref => sub { $self->unban(@_) }, help => "Removes bans set by moderators. Cannot remove any other types of bans. Usage: mod unban " }, - 'unmute' => { subref => sub { $self->unmute(@_) }, help => "Removes mutes set by moderators. Cannot remove any other types of mutes. Usage: mod unmute " }, - 'kb' => { subref => sub { $self->kb(@_) }, help => "Kickbans a nick from the channel. Cannot be used to set a custom banmask. Usage: mod kb " }, - }; + $self->{commands} = { + 'help' => {subref => sub { $self->help(@_) }, help => "Provides help about this command. Usage: mod help ; 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 "}, + 'ban' => {subref => sub { $self->ban(@_) }, help => "Bans a nick from the channel. Cannot be used to set a custom banmask. Usage: mod ban "}, + 'mute' => {subref => sub { $self->mute(@_) }, help => "Mutes a nick in the channel. Usage: mod mute "}, + 'unban' => {subref => sub { $self->unban(@_) }, help => "Removes bans set by moderators. Cannot remove any other types of bans. Usage: mod unban "}, + 'unmute' => {subref => sub { $self->unmute(@_) }, help => "Removes mutes set by moderators. Cannot remove any other types of mutes. Usage: mod unmute "}, + 'kb' => {subref => sub { $self->kb(@_) }, help => "Kickbans a nick from the channel. Cannot be used to set a custom banmask. Usage: mod kb "}, + }; } 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 "; + if (not defined $channel or $channel !~ /^#/) { return "Must specify channel from private message. Usage: mod $command "; } } - } - 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 " 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 " 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 [arguments]; commands are: $commands; see `mod help ` for more information."; + if (grep { $_ eq $command } keys %{$self->{commands}}) { + return $self->{commands}->{$command}->{subref}->($stuff); } else { - return "Usage: mod [arguments]; commands are: $commands; see `mod help ` for more information."; + my $commands = join ', ', sort keys %{$self->{commands}}; + if ($from !~ m/^#/) { return "Usage: mod [arguments]; commands are: $commands; see `mod help ` for more information."; } + else { return "Usage: mod [arguments]; commands are: $commands; see `mod help ` for more information."; } } - } } 1; diff --git a/Plugins/Spinach.pm b/Plugins/Spinach.pm index 2054c77a..10b352de 100644 --- a/Plugins/Spinach.pm +++ b/Plugins/Spinach.pm @@ -3,6 +3,7 @@ # file, You can obtain one at http://mozilla.org/MPL/2.0/. package Plugins::Spinach; + use parent 'Plugins::Plugin'; use warnings; use strict; @@ -10,6 +11,7 @@ use warnings; use strict; use FindBin; use lib "$FindBin::RealBin/../.."; use feature 'switch'; + no if $] >= 5.018, warnings => "experimental::smartmatch"; use feature 'unicode_strings'; @@ -28,7 +30,10 @@ use Text::Unidecode; use Encode; use Data::Dumper; -$Data::Dumper::Sortkeys = sub { my ($h) = @_; my @a = sort grep { not /^(?:seen_questions|alternativeSpellings)$/ } keys %$h; \@a }; + +$Data::Dumper::Sortkeys = sub { + my ($h) = @_; my @a = sort grep { not /^(?:seen_questions|alternativeSpellings)$/ } keys %$h; \@a; +}; $Data::Dumper::Useqq = 1; use PBot::HashObject; @@ -37,3273 +42,3049 @@ use Plugins::Spinach::Stats; use Plugins::Spinach::Rank; sub initialize { - my ($self, %conf) = @_; - $self->{pbot}->{commands}->register(sub { $self->spinach_cmd(@_) }, 'spinach', 0); + my ($self, %conf) = @_; + $self->{pbot}->{commands}->register(sub { $self->spinach_cmd(@_) }, 'spinach', 0); - $self->{pbot}->{timer}->register(sub { $self->spinach_timer }, 1, 'spinach timer'); + $self->{pbot}->{timer}->register(sub { $self->spinach_timer }, 1, 'spinach timer'); - $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.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->{channel} = $self->{pbot}->{registry}->get_value('spinach', 'channel') // '##spinach'; + $self->{channel} = $self->{pbot}->{registry}->get_value('spinach', 'channel') // '##spinach'; - my $default_file = $self->{pbot}->{registry}->get_value('spinach', 'file') // 'trivia.json'; - $self->{questions_filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . "/spinach/$default_file"; - $self->{stopwords_filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/spinach/stopwords'; - $self->{metadata_filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/spinach/metadata'; - $self->{stats_filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/spinach/stats.sqlite'; + my $default_file = $self->{pbot}->{registry}->get_value('spinach', 'file') // 'trivia.json'; + $self->{questions_filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . "/spinach/$default_file"; + $self->{stopwords_filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/spinach/stopwords'; + $self->{metadata_filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/spinach/metadata'; + $self->{stats_filename} = $self->{pbot}->{registry}->get_value('general', 'data_dir') . '/spinach/stats.sqlite'; - $self->{metadata} = PBot::HashObject->new(pbot => $self->{pbot}, name => 'Spinach Metadata', filename => $self->{metadata_filename}); - $self->{metadata}->load; - $self->set_metadata_defaults; + $self->{metadata} = PBot::HashObject->new(pbot => $self->{pbot}, name => 'Spinach Metadata', filename => $self->{metadata_filename}); + $self->{metadata}->load; + $self->set_metadata_defaults; - $self->{stats} = Plugins::Spinach::Stats->new(pbot => $self->{pbot}, filename => $self->{stats_filename}); - $self->{rankcmd} = Plugins::Spinach::Rank->new(pbot => $self->{pbot}, channel => $self->{channel}, filename => $self->{stats_filename}); + $self->{stats} = Plugins::Spinach::Stats->new(pbot => $self->{pbot}, filename => $self->{stats_filename}); + $self->{rankcmd} = Plugins::Spinach::Rank->new(pbot => $self->{pbot}, channel => $self->{channel}, filename => $self->{stats_filename}); - $self->create_states; - $self->load_questions; - $self->load_stopwords; + $self->create_states; + $self->load_questions; + $self->load_stopwords; - $self->{choosecategory_max_count} = 4; - $self->{picktruth_max_count} = 4; - $self->{tock_duration} = 30; + $self->{choosecategory_max_count} = 4; + $self->{picktruth_max_count} = 4; + $self->{tock_duration} = 30; } sub unload { - my $self = shift; - $self->{pbot}->{commands}->unregister('spinach'); - $self->{pbot}->{timer}->unregister('spinach timer'); - $self->{stats}->end if $self->{stats_running}; - $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->{pbot}->{commands}->unregister('spinach'); + $self->{pbot}->{timer}->unregister('spinach timer'); + $self->{stats}->end if $self->{stats_running}; + $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 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 lc $channel ne $self->{channel}; - $self->player_left($nick, $user, $host); - return 0; + 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 lc $channel ne $self->{channel}; + $self->player_left($nick, $user, $host); + return 0; } sub on_departure { - my ($self, $event_type, $event) = @_; - my ($nick, $user, $host, $channel) = ($event->{event}->nick, $event->{event}->user, $event->{event}->host, $event->{event}->to); - my $type = uc $event->{event}->type; - return 0 if $type ne 'QUIT' and lc $channel ne $self->{channel}; - $self->player_left($nick, $user, $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); + my $type = uc $event->{event}->type; + return 0 if $type ne 'QUIT' and lc $channel ne $self->{channel}; + $self->player_left($nick, $user, $host); + return 0; } sub load_questions { - my ($self, $filename) = @_; + my ($self, $filename) = @_; - if (not defined $filename) { - $filename = exists $self->{loaded_filename} ? $self->{loaded_filename} : $self->{questions_filename}; - } else { - $filename = $self->{pbot}->{registry}->get_value('general', 'data_dir') . "/spinach/$filename"; - } + if (not defined $filename) { $filename = exists $self->{loaded_filename} ? $self->{loaded_filename} : $self->{questions_filename}; } + else { $filename = $self->{pbot}->{registry}->get_value('general', 'data_dir') . "/spinach/$filename"; } - $self->{pbot}->{logger}->log("Spinach: Loading questions from $filename...\n"); + $self->{pbot}->{logger}->log("Spinach: Loading questions from $filename...\n"); - my $contents = do { - open my $fh, '<', $filename or do { - $self->{pbot}->{logger}->log("Spinach: Failed to open $filename: $!\n"); - return "Failed to load $filename"; + my $contents = do { + open my $fh, '<', $filename or do { + $self->{pbot}->{logger}->log("Spinach: Failed to open $filename: $!\n"); + return "Failed to load $filename"; + }; + local $/; + my $text = <$fh>; + close $fh; + $text; }; - local $/; - my $text = <$fh>; - close $fh; - $text; - }; - $self->{loaded_filename} = $filename; + $self->{loaded_filename} = $filename; - $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; } - if (not exists $question->{value}) { - $question->{value} = 0; - } + if (not exists $question->{value}) { $question->{value} = 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}}; - # $self->{pbot}->{logger}->log("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}}; - $self->{pbot}->{logger}->log("Spinach: Loaded $questions questions in $categories categories.\n"); - return "Loaded $questions questions in $categories categories."; + # $self->{pbot}->{logger}->log("Category [$category]: $count\n"); + $categories++; + } + + $self->{pbot}->{logger}->log("Spinach: Loaded $questions questions in $categories categories.\n"); + return "Loaded $questions questions in $categories categories."; } sub save_questions { - my $self = shift; - my $json = JSON->new; - my $json_text = $json->pretty->canonical->utf8->encode($self->{questions}); - my $filename = exists $self->{loaded_filename} ? $self->{loaded_filename} : $self->{questions_filename}; - open my $fh, '>', $filename or do { - $self->{pbot}->{logger}->log("Failed to open Spinach file $filename: $!\n"); - return; - }; - print $fh "$json_text\n"; - close $fh; + my $self = shift; + my $json = JSON->new; + my $json_text = $json->pretty->canonical->utf8->encode($self->{questions}); + my $filename = exists $self->{loaded_filename} ? $self->{loaded_filename} : $self->{questions_filename}; + open my $fh, '>', $filename or do { + $self->{pbot}->{logger}->log("Failed to open Spinach file $filename: $!\n"); + return; + }; + print $fh "$json_text\n"; + close $fh; } sub load_stopwords { - my $self = shift; + my $self = shift; - open my $fh, '<', $self->{stopwords_filename} or do { - $self->{pbot}->{logger}->log("Spinach: Failed to open $self->{stopwords_filename}: $!\n"); - return; - }; + open my $fh, '<', $self->{stopwords_filename} or do { + $self->{pbot}->{logger}->log("Spinach: Failed to open $self->{stopwords_filename}: $!\n"); + return; + }; - foreach my $word (<$fh>) { - chomp $word; - $self->{stopwords}{$word} = 1; - } - close $fh; + foreach my $word (<$fh>) { + chomp $word; + $self->{stopwords}{$word} = 1; + } + close $fh; } sub set_metadata_defaults { - my ($self) = @_; - my $defaults = { - category_choices => 7, - category_autopick => 0, - min_players => 2, - stats => 1, - seen_expiry => 432000, - min_difficulty => 0, - max_difficulty => 25000, - max_missed_inputs => 3, - debug_state => 0, - }; + my ($self) = @_; + my $defaults = { + category_choices => 7, + category_autopick => 0, + min_players => 2, + stats => 1, + seen_expiry => 432000, + min_difficulty => 0, + max_difficulty => 25000, + max_missed_inputs => 3, + debug_state => 0, + }; - if ($self->{metadata}->exists('settings')) { - $self->{metadata}->add('settings', $defaults, 1); - } else { - foreach my $key (keys %$defaults) { - if (not $self->{metadata}->exists('settings', $key)) { - $self->{metadata}->set('settings', $key, $defaults->{$key}, 1); - } + if ($self->{metadata}->exists('settings')) { $self->{metadata}->add('settings', $defaults, 1); } + else { + foreach my $key (keys %$defaults) { + if (not $self->{metadata}->exists('settings', $key)) { $self->{metadata}->set('settings', $key, $defaults->{$key}, 1); } + } } - } } my %color = ( - white => "\x0300", - black => "\x0301", - blue => "\x0302", - green => "\x0303", - red => "\x0304", - maroon => "\x0305", - purple => "\x0306", - orange => "\x0307", - yellow => "\x0308", - lightgreen => "\x0309", - teal => "\x0310", - cyan => "\x0311", - lightblue => "\x0312", - magneta => "\x0313", - gray => "\x0314", - lightgray => "\x0315", + white => "\x0300", + black => "\x0301", + blue => "\x0302", + green => "\x0303", + red => "\x0304", + maroon => "\x0305", + purple => "\x0306", + orange => "\x0307", + yellow => "\x0308", + lightgreen => "\x0309", + teal => "\x0310", + cyan => "\x0311", + lightblue => "\x0312", + magneta => "\x0313", + gray => "\x0314", + lightgray => "\x0315", - bold => "\x02", - italics => "\x1D", - underline => "\x1F", - reverse => "\x16", + bold => "\x02", + italics => "\x1D", + underline => "\x1F", + reverse => "\x16", - reset => "\x0F", + reset => "\x0F", ); sub spinach_cmd { - my ($self, $from, $nick, $user, $host, $arguments) = @_; - $arguments =~ s/^\s+|\s+$//g; + my ($self, $from, $nick, $user, $host, $arguments) = @_; + $arguments =~ s/^\s+|\s+$//g; - my $usage = "Usage: spinach join|exit|ready|unready|choose|lie|reroll|skip|keep|score|show|rank|categories|filter|set|unset|kick|abort; for more information about a command: spinach help "; + my $usage = + "Usage: spinach join|exit|ready|unready|choose|lie|reroll|skip|keep|score|show|rank|categories|filter|set|unset|kick|abort; for more information about a command: spinach help "; - my $command; - ($command, $arguments) = split / /, $arguments, 2; - $command = defined $command ? lc $command : ''; + my $command; + ($command, $arguments) = split / /, $arguments, 2; + $command = defined $command ? lc $command : ''; - my ($channel, $result); + my ($channel, $result); - given ($command) { - when ('help') { - given ($arguments) { + given ($command) { when ('help') { - return "Seriously?"; + given ($arguments) { + when ('help') { return "Seriously?"; } + + when ('join') { return "Help is coming soon."; } + + when ('ready') { return "Help is coming soon."; } + + when ('exit') { return "Help is coming soon."; } + + when ('skip') { return "Use `skip` to skip a question and return to the \"choose category\" stage. A majority of the players must agree to skip."; } + + when ('keep') { return "Use `keep` to vote to prevent the current question from being rerolled or skipped."; } + + when ('abort') { return "Help is coming soon."; } + + when ('reroll') { return "Use `reroll` to get a different question from the same category."; } + + when ('kick') { return "Help is coming soon."; } + + when ('players') { return "Help is coming soon."; } + + when ('score') { return "Help is coming soon."; } + + when ('choose') { return "Help is coming soon."; } + + when ('lie') { return "Help is coming soon."; } + + when ('truth') { return "Help is coming soon."; } + + when ('show') { return "Show the current question again."; } + + when ('categories') { return "Help is coming soon."; } + + when ('filter') { return "Help is coming soon."; } + + when ('set') { return "Help is coming soon."; } + + when ('unset') { return "Help is coming soon."; } + + when ('rank') { return "Help is coming soon."; } + + default { + if (length $arguments) { return "Spinach has no such command '$arguments'. I can't help you with that."; } + else { return "Usage: spinach help "; } + } + } + } + + when ('edit') { + my $admin = $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host"); + + if (not $admin) { return "$nick: Sorry, only admins may edit questions."; } + + my ($id, $key, $value) = split /\s+/, $arguments, 3; + + if (not defined $id) { return "Usage: spinach edit [key [value]]"; } + + $id =~ s/,//g; + + my $question; + foreach my $q (@{$self->{questions}->{questions}}) { + if ($q->{id} == $id) { + $question = $q; + last; + } + } + + if (not defined $question) { return "$nick: No such question."; } + + if (not defined $key) { + my $dump = Dumper $question; + $dump =~ s/\$VAR\d+ = \{\s*//; + $dump =~ s/ \};\s*$//; + return "$nick: Question $id: $dump"; + } + + if (not defined $value) { + my $v = $question->{$key} // 'unset'; + return "$nick: Question $id: $key => $v"; + } + + if ($key !~ m/^(?:question|answer|category)$/i) { return "$nick: You may not edit that key."; } + + $question->{$key} = $value; + $self->save_questions; + return "$nick: Question $id: $key set to $value"; + } + + when ('load') { + my $u = $self->{pbot}->{users}->loggedin($self->{channel}, "$nick!$user\@$host"); + if (not $u or not $self->{pbot}->{capabilities}->userhas($u, 'botowner')) { return "$nick: Sorry, only botowners may reload the questions."; } + + $arguments = undef if not length $arguments; + return $self->load_questions($arguments); } when ('join') { - return "Help is coming soon."; + if ($self->{current_state} eq 'nogame') { + $self->{state_data} = {players => [], counter => 0}; + $self->{current_state} = 'getplayers'; + } + + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); + + foreach my $player (@{$self->{state_data}->{players}}) { + if ($player->{id} == $id) { return "$nick: You have already joined this game."; } + } + + my $player = {id => $id, name => $nick, score => 0, ready => $self->{current_state} eq 'getplayers' ? 0 : 1, missedinputs => 0}; + push @{$self->{state_data}->{players}}, $player; + $self->{state_data}->{counter} = 0; + return "/msg $self->{channel} $nick has joined the game!"; } when ('ready') { - return "Help is coming soon."; + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); + + foreach my $player (@{$self->{state_data}->{players}}) { + if ($player->{id} == $id) { + if ($self->{current_state} ne 'getplayers') { return "/msg $nick This is not the time to use `ready`."; } + + if ($player->{ready} == 0) { + $player->{ready} = 1; + $player->{score} = 0; + return "/msg $self->{channel} $nick is ready!"; + } else { + return "/msg $nick You are already ready."; + } + } + } + + return "$nick: You haven't joined this game yet. Use `j` to play now!"; + } + + when ('unready') { + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); + + foreach my $player (@{$self->{state_data}->{players}}) { + if ($player->{id} == $id) { + if ($self->{current_state} ne 'getplayers') { return "/msg $nick This is not the time to use `unready`."; } + + if ($player->{ready} != 0) { + $player->{ready} = 0; + return "/msg $self->{channel} $nick is no longer ready!"; + } else { + return "/msg $nick You are already not ready."; + } + } + } + + return "$nick: You haven't joined this game yet. Use `j` to play now!"; } when ('exit') { - return "Help is coming soon."; - } + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); + my $removed = 0; - when ('skip') { - return "Use `skip` to skip a question and return to the \"choose category\" stage. A majority of the players must agree to skip."; - } + for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { + if ($self->{state_data}->{players}->[$i]->{id} == $id) { + splice @{$self->{state_data}->{players}}, $i--, 1; + $removed = 1; + } + } - when ('keep') { - return "Use `keep` to vote to prevent the current question from being rerolled or skipped."; + if ($removed) { + if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 } + + if (not @{$self->{state_data}->{players}}) { + $self->{current_state} = 'nogame'; + return "/msg $self->{channel} $nick has left the game! All players have left. The game has been stopped."; + } else { + return "/msg $self->{channel} $nick has left the game!"; + } + } else { + return "$nick: But you are not even playing the game."; + } } when ('abort') { - return "Help is coming soon."; + if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { return "$nick: Sorry, only admins may abort the game."; } + + $self->{current_state} = 'gameover'; + return "/msg $self->{channel} $nick: The game has been aborted."; } - when ('reroll') { - return "Use `reroll` to get a different question from the same category."; + when ($_ eq 'score' or $_ eq 'players') { + if ($self->{current_state} eq 'getplayers') { + my @names; + foreach my $player (@{$self->{state_data}->{players}}) { + if (not $player->{ready}) { push @names, "$player->{name} $color{red}(not ready)$color{reset}"; } + else { push @names, $player->{name}; } + } + + my $players = join ', ', @names; + $players = 'none' if not @names; + return "Current players: $players"; + } + + # score + if (not @{$self->{state_data}->{players}}) { return "There is nobody playing right now."; } + + my $text = ''; + my $comma = ''; + foreach my $player (sort { $b->{score} <=> $a->{score} } @{$self->{state_data}->{players}}) { + $text .= "$comma$player->{name}: " . $self->commify($player->{score}); + $comma = '; '; + } + return $text; } when ('kick') { - return "Help is coming soon."; + if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { return "$nick: Sorry, only admins may kick people from the game."; } + + if (not length $arguments) { return "Usage: spinach kick "; } + + my $removed = 0; + + for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { + if (lc $self->{state_data}->{players}->[$i]->{name} eq $arguments) { + splice @{$self->{state_data}->{players}}, $i--, 1; + $removed = 1; + } + } + + if ($removed) { + if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 } + return "/msg $self->{channel} $nick: $arguments has been kicked from the game."; + } else { + return "$nick: $arguments isn't even in the game."; + } } - when ('players') { - return "Help is coming soon."; + when ('n') { return $self->normalize_text($arguments); } + + when ('v') { + my ($truth, $lie) = split /;/, $arguments; + return $self->validate_lie($self->normalize_text($truth), $self->normalize_text($lie)); } - when ('score') { - return "Help is coming soon."; + when ('reroll') { + if ($self->{current_state} =~ /getlies$/) { + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); + + my $player; + my $rerolled = 0; + my $keep; + foreach my $i (@{$self->{state_data}->{players}}) { + if ($i->{id} == $id) { + $i->{reroll} = 1; + delete $i->{keep}; + $rerolled++; + $player = $i; + } elsif ($i->{reroll}) { + $rerolled++; + } elsif ($i->{keep}) { + $keep++; + } + } + + if (not $player) { return "$nick: You are not playing in this game. Use `j` to start playing now!"; } + + my $needed = int(@{$self->{state_data}->{players}} / 2) + 1; + $needed -= $rerolled; + $needed += $keep; + + my $votes_needed; + if ($needed == 1) { $votes_needed = "$needed more vote to reroll!"; } + elsif ($needed > 1) { $votes_needed = "$needed more votes to reroll!"; } + else { $votes_needed = "Rerolling..."; } + + return "/msg $self->{channel} $color{red}$nick has voted to reroll for another question from the same category! $color{reset}$votes_needed"; + } else { + return "$nick: This command can be used only during the \"submit lies\" stage."; + } } - when ('choose') { - return "Help is coming soon."; + when ('skip') { + if ($self->{current_state} =~ /getlies$/) { + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); + + my $player; + my $skipped = 0; + my $keep = 0; + foreach my $i (@{$self->{state_data}->{players}}) { + if ($i->{id} == $id) { + $i->{skip} = 1; + delete $i->{keep}; + $skipped++; + $player = $i; + } elsif ($i->{skip}) { + $skipped++; + } elsif ($i->{keep}) { + $keep++; + } + } + + if (not $player) { return "$nick: You are not playing in this game. Use `j` to start playing now!"; } + + my $needed = int(@{$self->{state_data}->{players}} / 2) + 1; + $needed -= $skipped; + $needed += $keep; + + my $votes_needed; + if ($needed == 1) { $votes_needed = "$needed more vote to skip!"; } + elsif ($needed > 1) { $votes_needed = "$needed more votes to skip!"; } + else { $votes_needed = "Skipping..."; } + + return "/msg $self->{channel} $color{red}$nick has voted to skip this category! $color{reset}$votes_needed"; + } else { + return "$nick: This command can be used only during the \"submit lies\" stage."; + } } - when ('lie') { - return "Help is coming soon."; + when ('keep') { + if ($self->{current_state} =~ /getlies$/) { + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); + + my $player; + foreach my $i (@{$self->{state_data}->{players}}) { + if ($i->{id} == $id) { + $i->{keep} = 1; + delete $i->{skip}; + delete $i->{reroll}; + $player = $i; + last; + } + } + + if (not $player) { return "$nick: You are not playing in this game. Use `j` to start playing now!"; } + + return "/msg $self->{channel} $color{green}$nick has voted to keep playing the current question!"; + } else { + return "$nick: This command can be used only during the \"submit lies\" stage."; + } } - when ('truth') { - return "Help is coming soon."; - } + when ($_ eq 'lie' or $_ eq 'truth' or $_ eq 'choose') { + $arguments = lc $arguments; + if ($self->{current_state} =~ /choosecategory$/) { + if (not length $arguments) { return "Usage: spinach choose "; } - when ('show') { - return "Show the current question again."; - } + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - when ('categories') { - return "Help is coming soon."; - } + if (not @{$self->{state_data}->{players}} or $id != $self->{state_data}->{players}->[$self->{state_data}->{current_player}]->{id}) { + return "$nick: It is not your turn to choose a category."; + } - when ('filter') { - return "Help is coming soon."; - } + if ($arguments !~ /^[0-9]+$/) { return "$nick: Please choose a category number. $self->{state_data}->{categories_text}"; } - when ('set') { - return "Help is coming soon."; - } + $arguments--; - when ('unset') { - return "Help is coming soon."; - } + if ($arguments < 0 or $arguments >= @{$self->{state_data}->{category_options}}) { + return "$nick: Choice out of range. Please choose a valid category. $self->{state_data}->{categories_text}"; + } - when ('rank') { - return "Help is coming soon."; - } + if ($arguments == @{$self->{state_data}->{category_options}} - 2) { + $arguments = (@{$self->{state_data}->{category_options}} - 2) * rand; + $self->{state_data}->{current_category} = $self->{state_data}->{category_options}->[$arguments]; + return "/msg $self->{channel} $nick has chosen RANDOM CATEGORY! Randomly choosing category: $self->{state_data}->{current_category}!"; + } elsif ($arguments == @{$self->{state_data}->{category_options}} - 1) { + $self->{state_data}->{reroll_category} = 1; + return "/msg $self->{channel} $nick has chosen REROLL CATEGORIES! Rerolling categories..."; + } else { + $self->{state_data}->{current_category} = $self->{state_data}->{category_options}->[$arguments]; + return "/msg $self->{channel} $nick has chosen $self->{state_data}->{current_category}!"; + } + } - default { - if (length $arguments) { - return "Spinach has no such command '$arguments'. I can't help you with that."; - } else { - return "Usage: spinach help "; - } - } - } - } + if ($self->{current_state} =~ /getlies$/) { + if (not length $arguments) { return "Usage: spinach lie "; } - when ('edit') { - my $admin = $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host"); + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - if (not $admin) { - return "$nick: Sorry, only admins may edit questions."; - } + my $player; + foreach my $i (@{$self->{state_data}->{players}}) { + if ($i->{id} == $id) { + $player = $i; + last; + } + } - my ($id, $key, $value) = split /\s+/, $arguments, 3; + if (not $player) { return "$nick: You are not playing in this game. Use `j` to start playing now!"; } - if (not defined $id) { - return "Usage: spinach edit [key [value]]"; - } + $arguments = $self->normalize_text($arguments); - $id =~ s/,//g; - - my $question; - foreach my $q (@{$self->{questions}->{questions}}) { - if ($q->{id} == $id) { - $question = $q; - last; - } - } - - if (not defined $question) { - return "$nick: No such question."; - } - - if (not defined $key) { - my $dump = Dumper $question; - $dump =~ s/\$VAR\d+ = \{\s*//; - $dump =~ s/ \};\s*$//; - return "$nick: Question $id: $dump"; - } - - if (not defined $value) { - my $v = $question->{$key} // 'unset'; - return "$nick: Question $id: $key => $v"; - } - - if ($key !~ m/^(?:question|answer|category)$/i) { - return "$nick: You may not edit that key."; - } - - $question->{$key} = $value; - $self->save_questions; - return "$nick: Question $id: $key set to $value"; - } - - when ('load') { - my $u = $self->{pbot}->{users}->loggedin($self->{channel}, "$nick!$user\@$host"); - if (not $u or not $self->{pbot}->{capabilities}->userhas($u, 'botowner')) { - return "$nick: Sorry, only botowners may reload the questions."; - } - - $arguments = undef if not length $arguments; - return $self->load_questions($arguments); - } - - when ('join') { - if ($self->{current_state} eq 'nogame') { - $self->{state_data} = { players => [], counter => 0 }; - $self->{current_state} = 'getplayers'; - } - - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - - foreach my $player (@{$self->{state_data}->{players}}) { - if ($player->{id} == $id) { - return "$nick: You have already joined this game."; - } - } - - my $player = { id => $id, name => $nick, score => 0, ready => $self->{current_state} eq 'getplayers' ? 0 : 1, missedinputs => 0 }; - push @{$self->{state_data}->{players}}, $player; - $self->{state_data}->{counter} = 0; - return "/msg $self->{channel} $nick has joined the game!"; - } - - when ('ready') { - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - - foreach my $player (@{$self->{state_data}->{players}}) { - if ($player->{id} == $id) { - if ($self->{current_state} ne 'getplayers') { - return "/msg $nick This is not the time to use `ready`."; - } - - if ($player->{ready} == 0) { - $player->{ready} = 1; - $player->{score} = 0; - return "/msg $self->{channel} $nick is ready!"; - } else { - return "/msg $nick You are already ready."; - } - } - } - - return "$nick: You haven't joined this game yet. Use `j` to play now!"; - } - - when ('unready') { - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - - foreach my $player (@{$self->{state_data}->{players}}) { - if ($player->{id} == $id) { - if ($self->{current_state} ne 'getplayers') { - return "/msg $nick This is not the time to use `unready`."; - } - - if ($player->{ready} != 0) { - $player->{ready} = 0; - return "/msg $self->{channel} $nick is no longer ready!"; - } else { - return "/msg $nick You are already not ready."; - } - } - } - - return "$nick: You haven't joined this game yet. Use `j` to play now!"; - } - - when ('exit') { - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - my $removed = 0; - - for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { - if ($self->{state_data}->{players}->[$i]->{id} == $id) { - splice @{$self->{state_data}->{players}}, $i--, 1; - $removed = 1; - } - } - - if ($removed) { - if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { - $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 - } - - if (not @{$self->{state_data}->{players}}) { - $self->{current_state} = 'nogame'; - return "/msg $self->{channel} $nick has left the game! All players have left. The game has been stopped."; - } else { - return "/msg $self->{channel} $nick has left the game!"; - } - } else { - return "$nick: But you are not even playing the game."; - } - } - - when ('abort') { - if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { - return "$nick: Sorry, only admins may abort the game."; - } - - $self->{current_state} = 'gameover'; - return "/msg $self->{channel} $nick: The game has been aborted."; - } - - when ($_ eq 'score' or $_ eq 'players') { - if ($self->{current_state} eq 'getplayers') { - my @names; - foreach my $player (@{$self->{state_data}->{players}}) { - if (not $player->{ready}) { - push @names, "$player->{name} $color{red}(not ready)$color{reset}"; - } else { - push @names, $player->{name}; - } - } - - my $players = join ', ', @names; - $players = 'none' if not @names; - return "Current players: $players"; - } - - # score - if (not @{$self->{state_data}->{players}}) { - return "There is nobody playing right now."; - } - - my $text = ''; - my $comma = ''; - foreach my $player (sort { $b->{score} <=> $a->{score} } @{$self->{state_data}->{players}}) { - $text .= "$comma$player->{name}: " . $self->commify($player->{score}); - $comma = '; '; - } - return $text; - } - - when ('kick') { - if (not $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host")) { - return "$nick: Sorry, only admins may kick people from the game."; - } - - if (not length $arguments) { - return "Usage: spinach kick "; - } - - my $removed = 0; - - for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { - if (lc $self->{state_data}->{players}->[$i]->{name} eq $arguments) { - splice @{$self->{state_data}->{players}}, $i--, 1; - $removed = 1; - } - } - - if ($removed) { - if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { - $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 - } - return "/msg $self->{channel} $nick: $arguments has been kicked from the game."; - } else { - return "$nick: $arguments isn't even in the game."; - } - } - - when ('n') { - return $self->normalize_text($arguments); - } - - when ('v') { - my ($truth, $lie) = split /;/, $arguments; - return $self->validate_lie($self->normalize_text($truth), $self->normalize_text($lie)); - } - - when ('reroll') { - if ($self->{current_state} =~ /getlies$/) { - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - - my $player; - my $rerolled = 0; - my $keep; - foreach my $i (@{$self->{state_data}->{players}}) { - if ($i->{id} == $id) { - $i->{reroll} = 1; - delete $i->{keep}; - $rerolled++; - $player = $i; - } elsif ($i->{reroll}) { - $rerolled++; - } elsif ($i->{keep}) { - $keep++; - } - } - - if (not $player) { - return "$nick: You are not playing in this game. Use `j` to start playing now!"; - } - - my $needed = int (@{$self->{state_data}->{players}} / 2) + 1; - $needed -= $rerolled; - $needed += $keep; - - my $votes_needed; - if ($needed == 1) { - $votes_needed = "$needed more vote to reroll!"; - } elsif ($needed > 1) { - $votes_needed = "$needed more votes to reroll!"; - } else { - $votes_needed = "Rerolling..."; - } - - return "/msg $self->{channel} $color{red}$nick has voted to reroll for another question from the same category! $color{reset}$votes_needed"; - } else { - return "$nick: This command can be used only during the \"submit lies\" stage."; - } - } - - when ('skip') { - if ($self->{current_state} =~ /getlies$/) { - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - - my $player; - my $skipped = 0; - my $keep = 0; - foreach my $i (@{$self->{state_data}->{players}}) { - if ($i->{id} == $id) { - $i->{skip} = 1; - delete $i->{keep}; - $skipped++; - $player = $i; - } elsif ($i->{skip}) { - $skipped++; - } elsif ($i->{keep}) { - $keep++; - } - } - - if (not $player) { - return "$nick: You are not playing in this game. Use `j` to start playing now!"; - } - - my $needed = int (@{$self->{state_data}->{players}} / 2) + 1; - $needed -= $skipped; - $needed += $keep; - - my $votes_needed; - if ($needed == 1) { - $votes_needed = "$needed more vote to skip!"; - } elsif ($needed > 1) { - $votes_needed = "$needed more votes to skip!"; - } else { - $votes_needed = "Skipping..."; - } - - return "/msg $self->{channel} $color{red}$nick has voted to skip this category! $color{reset}$votes_needed"; - } else { - return "$nick: This command can be used only during the \"submit lies\" stage."; - } - } - - when ('keep') { - if ($self->{current_state} =~ /getlies$/) { - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - - my $player; - foreach my $i (@{$self->{state_data}->{players}}) { - if ($i->{id} == $id) { - $i->{keep} = 1; - delete $i->{skip}; - delete $i->{reroll}; - $player = $i; - last; - } - } - - if (not $player) { - return "$nick: You are not playing in this game. Use `j` to start playing now!"; - } - - return "/msg $self->{channel} $color{green}$nick has voted to keep playing the current question!"; - } else { - return "$nick: This command can be used only during the \"submit lies\" stage."; - } - } - - when ($_ eq 'lie' or $_ eq 'truth' or $_ eq 'choose') { - $arguments = lc $arguments; - if ($self->{current_state} =~ /choosecategory$/) { - if (not length $arguments) { - return "Usage: spinach choose "; - } - - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - - if (not @{$self->{state_data}->{players}} or $id != $self->{state_data}->{players}->[$self->{state_data}->{current_player}]->{id}) { - return "$nick: It is not your turn to choose a category."; - } - - if ($arguments !~ /^[0-9]+$/) { - return "$nick: Please choose a category number. $self->{state_data}->{categories_text}"; - } - - $arguments--; - - if ($arguments < 0 or $arguments >= @{$self->{state_data}->{category_options}}) { - return "$nick: Choice out of range. Please choose a valid category. $self->{state_data}->{categories_text}"; - } - - if ($arguments == @{$self->{state_data}->{category_options}} - 2) { - $arguments = (@{$self->{state_data}->{category_options}} - 2) * rand; - $self->{state_data}->{current_category} = $self->{state_data}->{category_options}->[$arguments]; - return "/msg $self->{channel} $nick has chosen RANDOM CATEGORY! Randomly choosing category: $self->{state_data}->{current_category}!"; - } elsif ($arguments == @{$self->{state_data}->{category_options}} - 1) { - $self->{state_data}->{reroll_category} = 1; - return "/msg $self->{channel} $nick has chosen REROLL CATEGORIES! Rerolling categories..."; - } else { - $self->{state_data}->{current_category} = $self->{state_data}->{category_options}->[$arguments]; - return "/msg $self->{channel} $nick has chosen $self->{state_data}->{current_category}!"; - } - } - - if ($self->{current_state} =~ /getlies$/) { - if (not length $arguments) { - return "Usage: spinach lie "; - } - - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - - my $player; - foreach my $i (@{$self->{state_data}->{players}}) { - if ($i->{id} == $id) { - $player = $i; - last; - } - } - - if (not $player) { - return "$nick: You are not playing in this game. Use `j` to start playing now!"; - } - - $arguments = $self->normalize_text($arguments); - - my @truth_count = split /\s/, $self->{state_data}->{current_question}->{answer}; - my @lie_count = split /\s/, $arguments; + my @truth_count = split /\s/, $self->{state_data}->{current_question}->{answer}; + my @lie_count = split /\s/, $arguments; =cut if (@truth_count > 1 and @lie_count == 1) { return "/msg $nick Your lie cannot be one word for this question. Please try again."; } =cut - my $found_truth = 0; - if (not $self->validate_lie($self->{state_data}->{current_question}->{answer}, $arguments)) { - $found_truth = 1; - } + my $found_truth = 0; - foreach my $alt (@{$self->{state_data}->{current_question}->{alternativeSpellings}}) { - if (not $self->validate_lie($alt, $arguments)) { - $found_truth = 1; - last; - } - } + if (not $self->validate_lie($self->{state_data}->{current_question}->{answer}, $arguments)) { $found_truth = 1; } - if (not $found_truth and ++$player->{lie_count} > 2) { - return "/msg $nick You cannot change your lie again this round."; - } + foreach my $alt (@{$self->{state_data}->{current_question}->{alternativeSpellings}}) { + if (not $self->validate_lie($alt, $arguments)) { + $found_truth = 1; + last; + } + } - if ($found_truth) { - $self->send_message($self->{channel}, "$color{yellow}$nick has found the truth!$color{reset}"); - return "$nick: Your lie is too similar to the truth! Please submit a different lie."; - } + if (not $found_truth and ++$player->{lie_count} > 2) { return "/msg $nick You cannot change your lie again this round."; } - my $changed = exists $player->{lie}; - $player->{lie} = $arguments; + if ($found_truth) { + $self->send_message($self->{channel}, "$color{yellow}$nick has found the truth!$color{reset}"); + return "$nick: Your lie is too similar to the truth! Please submit a different lie."; + } - if ($changed) { - return "/msg $self->{channel} $nick has changed their lie!"; - } else { - return "/msg $self->{channel} $nick has submitted a lie!"; - } - } + my $changed = exists $player->{lie}; + $player->{lie} = $arguments; - if ($self->{current_state} =~ /findtruth$/) { - if (not length $arguments) { - return "Usage: spinach truth "; - } + if ($changed) { return "/msg $self->{channel} $nick has changed their lie!"; } + else { return "/msg $self->{channel} $nick has submitted a lie!"; } + } - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); + if ($self->{current_state} =~ /findtruth$/) { + if (not length $arguments) { return "Usage: spinach truth "; } - my $player; - foreach my $i (@{$self->{state_data}->{players}}) { - if ($i->{id} == $id) { - $player = $i; - last; - } - } + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - if (not $player) { - return "$nick: You are not playing in this game. Use `j` to start playing now!"; - } + my $player; + foreach my $i (@{$self->{state_data}->{players}}) { + if ($i->{id} == $id) { + $player = $i; + last; + } + } - if ($arguments !~ /^[0-9]+$/) { - return "$nick: Please select a truth number. $self->{state_data}->{current_choices_text}"; - } + if (not $player) { return "$nick: You are not playing in this game. Use `j` to start playing now!"; } - $arguments--; + if ($arguments !~ /^[0-9]+$/) { return "$nick: Please select a truth number. $self->{state_data}->{current_choices_text}"; } - if ($arguments < 0 or $arguments >= @{$self->{state_data}->{current_choices}}) { - return "$nick: Selection out of range. Please select a valid truth. $self->{state_data}->{current_choices_text}"; - } + $arguments--; - my $changed = exists $player->{truth}; - $player->{truth} = uc $self->{state_data}->{current_choices}->[$arguments]; + if ($arguments < 0 or $arguments >= @{$self->{state_data}->{current_choices}}) { + return "$nick: Selection out of range. Please select a valid truth. $self->{state_data}->{current_choices_text}"; + } - if ($player->{truth} eq $player->{lie}) { - delete $player->{truth}; - return "$nick: You cannot select your own lie!"; - } + my $changed = exists $player->{truth}; + $player->{truth} = uc $self->{state_data}->{current_choices}->[$arguments]; - if ($changed) { - return "/msg $self->{channel} $nick has selected a different truth!"; - } else { - return "/msg $self->{channel} $nick has selected a truth!"; - } - } + if ($player->{truth} eq $player->{lie}) { + delete $player->{truth}; + return "$nick: You cannot select your own lie!"; + } - return "$nick: It is not time to use this command."; - } + if ($changed) { return "/msg $self->{channel} $nick has selected a different truth!"; } + else { return "/msg $self->{channel} $nick has selected a truth!"; } + } - when ('show') { - if ($self->{current_state} =~ /(?:getlies|findtruth|showlies)$/) { - $self->showquestion($self->{state_data}, 1); - return; - } - - return "$nick: There is nothing to show right now."; - } - - when ('categories') { - if (not length $arguments) { - return "Usage: spinach categories "; - } - - my $result = eval { - use re::engine::RE2 -strict => 1; - my @categories = grep { /$arguments/i } keys %{$self->{categories}}; - if (not @categories) { - return "No categories found."; - } - - my $text = ""; - my $comma = ""; - foreach my $cat (sort @categories) { - $text .= "$comma$cat: " . keys %{$self->{categories}{$cat}}; - $comma = ", "; - } - return $text; - }; - - return "$arguments: $@" if $@; - return $result; - } - - when ('filter') { - my ($cmd, $args) = split / /, $arguments, 2; - $cmd = lc $cmd; - - if (not length $cmd) { - return "Usage: spinach filter include | exclude | show | clear"; - } - - given ($cmd) { - when ($_ eq 'include' or $_ eq 'exclude') { - if (not length $args) { - return "Usage: spinach filter $_ "; - } - - eval { "" =~ /$args/ }; - return "Bad filter $args: $@" if $@; - - my @categories = grep { /$args/i } keys %{$self->{categories}}; - if (not @categories) { - return "Bad filter: No categories match. Try again."; - } - - $self->{metadata}->set('filter', "category_" . $_ . "_filter", $args); - return "Spinach $_ filter set."; - } - - when ('clear') { - $self->{metadata}->remove('filter'); - return "Spinach filter cleared."; + return "$nick: It is not time to use this command."; } when ('show') { - if (not $self->{metadata}->exists('filter', 'category_include_filter') - and not $self->{metadata}->exists('filter', 'category_exclude_filter')) { - return "There is no Spinach filter set."; - } + if ($self->{current_state} =~ /(?:getlies|findtruth|showlies)$/) { + $self->showquestion($self->{state_data}, 1); + return; + } - my $text = "Spinach "; - my $comma = ""; - - if ($self->{metadata}->exists('filter', 'category_include_filter')) { - $text .= "include filter set to: " . $self->{metadata}->get_data('filter', 'category_include_filter'); - $comma = "; "; - } - - if ($self->{metadata}->exists('filter', 'category_exclude_filter')) { - $text .= $comma . "exclude filter set to: " . $self->{metadata}->get_data('filter', 'category_exclude_filter'); - } - - return $text; + return "$nick: There is nothing to show right now."; } - default { - return "Unknown filter command '$cmd'."; - } - } - } + when ('categories') { + if (not length $arguments) { return "Usage: spinach categories "; } - when ('state') { - my ($command, $args) = split /\s+/, $arguments; + my $result = eval { + use re::engine::RE2 -strict => 1; + my @categories = grep { /$arguments/i } keys %{$self->{categories}}; + if (not @categories) { return "No categories found."; } - if ($command eq 'show') { - return "Previous state: $self->{previous_state}; Current state: $self->{current_state}; previous result: $self->{state_data}->{previous_result}"; - } + my $text = ""; + my $comma = ""; + foreach my $cat (sort @categories) { + $text .= "$comma$cat: " . keys %{$self->{categories}{$cat}}; + $comma = ", "; + } + return $text; + }; - if ($command eq 'set') { - if (not length $args) { - return "Usage: spinach state set "; + return "$arguments: $@" if $@; + return $result; } - my $u = $self->{pbot}->{users}->loggedin($self->{channel}, "$nick!$user\@$host"); - if (not $self->{pbot}->{capabilities}->userhas($u, 'admin')) { - return "$nick: Sorry, only admins may set game state."; + when ('filter') { + my ($cmd, $args) = split / /, $arguments, 2; + $cmd = lc $cmd; + + if (not length $cmd) { return "Usage: spinach filter include | exclude | show | clear"; } + + given ($cmd) { + when ($_ eq 'include' or $_ eq 'exclude') { + if (not length $args) { return "Usage: spinach filter $_ "; } + + eval { "" =~ /$args/ }; + return "Bad filter $args: $@" if $@; + + my @categories = grep { /$args/i } keys %{$self->{categories}}; + if (not @categories) { return "Bad filter: No categories match. Try again."; } + + $self->{metadata}->set('filter', "category_" . $_ . "_filter", $args); + return "Spinach $_ filter set."; + } + + when ('clear') { + $self->{metadata}->remove('filter'); + return "Spinach filter cleared."; + } + + when ('show') { + if (not $self->{metadata}->exists('filter', 'category_include_filter') and not $self->{metadata}->exists('filter', 'category_exclude_filter')) { + return "There is no Spinach filter set."; + } + + my $text = "Spinach "; + my $comma = ""; + + if ($self->{metadata}->exists('filter', 'category_include_filter')) { + $text .= "include filter set to: " . $self->{metadata}->get_data('filter', 'category_include_filter'); + $comma = "; "; + } + + if ($self->{metadata}->exists('filter', 'category_exclude_filter')) { + $text .= $comma . "exclude filter set to: " . $self->{metadata}->get_data('filter', 'category_exclude_filter'); + } + + return $text; + } + + default { return "Unknown filter command '$cmd'."; } + } } - $self->{previous_state} = $self->{current_state}; - $self->{current_state} = $args; - return "State set to $args"; - } + when ('state') { + my ($command, $args) = split /\s+/, $arguments; - if ($command eq 'result') { - if (not length $args) { - return "Usage: spinach state result "; + if ($command eq 'show') { + return "Previous state: $self->{previous_state}; Current state: $self->{current_state}; previous result: $self->{state_data}->{previous_result}"; + } + + if ($command eq 'set') { + if (not length $args) { return "Usage: spinach state set "; } + + my $u = $self->{pbot}->{users}->loggedin($self->{channel}, "$nick!$user\@$host"); + if (not $self->{pbot}->{capabilities}->userhas($u, 'admin')) { return "$nick: Sorry, only admins may set game state."; } + + $self->{previous_state} = $self->{current_state}; + $self->{current_state} = $args; + return "State set to $args"; + } + + if ($command eq 'result') { + if (not length $args) { return "Usage: spinach state result "; } + + my $admin = $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host"); + if (not $admin) { return "$nick: Sorry, only admins may set game state."; } + + $self->{state_data}->{previous_result} = $self->{state_data}->{result}; + $self->{state_data}->{result} = $args; + return "State result set to $args"; + } + + return "Usage: spinach state show | set | result "; } - my $admin = $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host"); - if (not $admin) { - return "$nick: Sorry, only admins may set game state."; + when ('set') { + my ($index, $key, $value) = split /\s+/, $arguments; + + if (not defined $index) { return "Usage: spinach set [key [value]]"; } + + if (lc $index eq 'settings' and $key and lc $key eq 'stats' and defined $value and $self->{current_state} ne 'nogame') { + return "Spinach stats setting cannot be modified while a game is in progress."; + } + + my $admin = $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host"); + if (defined $value and not $admin) { return "$nick: Sorry, only Spinach admins may set game settings."; } + + return $self->{metadata}->set($index, $key, $value); } - $self->{state_data}->{previous_result} = $self->{state_data}->{result}; - $self->{state_data}->{result} = $args; - return "State result set to $args"; - } + when ('unset') { + my ($index, $key) = split /\s+/, $arguments; - return "Usage: spinach state show | set | result "; + if (not defined $index or not defined $key) { return "Usage: spinach unset "; } + + if (lc $index eq 'settings' and lc $key eq 'stats' and $self->{current_state} ne 'nogame') { + return "Spinach stats setting cannot be modified while a game is in progress."; + } + + my $admin = $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host"); + if (not $admin) { return "$nick: Sorry, only Spinach admins may set game settings."; } + + return $self->{metadata}->unset($index, $key); + } + + when ('rank') { return $self->{rankcmd}->rank($arguments); } + + default { return $usage; } } - when ('set') { - my ($index, $key, $value) = split /\s+/, $arguments; - - if (not defined $index) { - return "Usage: spinach set [key [value]]"; - } - - if (lc $index eq 'settings' and $key and lc $key eq 'stats' and defined $value and $self->{current_state} ne 'nogame') { - return "Spinach stats setting cannot be modified while a game is in progress."; - } - - my $admin = $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host"); - if (defined $value and not $admin) { - return "$nick: Sorry, only Spinach admins may set game settings."; - } - - return $self->{metadata}->set($index, $key, $value); - } - - when ('unset') { - my ($index, $key) = split /\s+/, $arguments; - - if (not defined $index or not defined $key) { - return "Usage: spinach unset "; - } - - if (lc $index eq 'settings' and lc $key eq 'stats' and $self->{current_state} ne 'nogame') { - return "Spinach stats setting cannot be modified while a game is in progress."; - } - - my $admin = $self->{pbot}->{users}->loggedin_admin($self->{channel}, "$nick!$user\@$host"); - if (not $admin) { - return "$nick: Sorry, only Spinach admins may set game settings."; - } - - return $self->{metadata}->unset($index, $key); - } - - when ('rank') { - return $self->{rankcmd}->rank($arguments); - } - - default { - return $usage; - } - } - - return $result; + return $result; } sub spinach_timer { - my $self = shift; - $self->run_one_state(); + my $self = shift; + $self->run_one_state(); } sub player_left { - my ($self, $nick, $user, $host) = @_; + my ($self, $nick, $user, $host) = @_; - my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); - my $removed = 0; - - for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { - if ($self->{state_data}->{players}->[$i]->{id} == $id) { - splice @{$self->{state_data}->{players}}, $i--, 1; - $removed = 1; - } - } - - if ($removed) { - if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { - $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 - } - $self->send_message($self->{channel}, "$nick has left the game!"); - } -} - -sub send_message { - my ($self, $to, $text, $delay) = @_; - $delay = 0 if not defined $delay; - my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); - my $message = { - nick => $botnick, user => 'spinach', host => 'localhost', command => 'spinach text', checkflood => 1, - message => $text - }; - $self->{pbot}->{interpreter}->add_message_to_output_queue($to, $message, $delay); -} - -sub add_new_suggestions { - my ($self, $state) = @_; - - my $question = undef; - my $modified = 0; - - foreach my $player (@{$state->{players}}) { - if ($player->{deceived}) { - $self->{pbot}->{logger}->log("Adding new suggestion for $state->{current_question}->{id}: $state->{current_question}->{question}: $player->{deceived}\n"); - - if (not grep { lc $_ eq lc $player->{deceived} } @{$state->{current_question}->{suggestions}}) { - if (not defined $question) { - foreach my $q (@{$self->{questions}->{questions}}) { - if ($q->{id} == $state->{current_question}->{id}) { - $question = $q; - last; - } - } - } - - push @{$question->{suggestions}}, uc $player->{deceived}; - $modified = 1; - } - } - } - - if ($modified) { - $self->save_questions; - } -} - -sub run_one_state { - my $self = shift; - - # check for naughty or missing players - if ($self->{current_state} =~ /r\dq\d/) { + my $id = $self->{pbot}->{messagehistory}->{database}->get_message_account_ancestor($nick, $user, $host); my $removed = 0; + for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { - if ($self->{state_data}->{players}->[$i]->{missedinputs} >= $self->{metadata}->get_data('settings', 'max_missed_inputs')) { - $self->send_message($self->{channel}, "$color{red}$self->{state_data}->{players}->[$i]->{name} has missed too many prompts and has been ejected from the game!$color{reset}"); - splice @{$self->{state_data}->{players}}, $i--, 1; - $removed = 1; - } + if ($self->{state_data}->{players}->[$i]->{id} == $id) { + splice @{$self->{state_data}->{players}}, $i--, 1; + $removed = 1; + } } if ($removed) { - if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { - $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 - } + if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 } + $self->send_message($self->{channel}, "$nick has left the game!"); + } +} + +sub send_message { + my ($self, $to, $text, $delay) = @_; + $delay = 0 if not defined $delay; + my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); + my $message = { + nick => $botnick, user => 'spinach', host => 'localhost', command => 'spinach text', checkflood => 1, + message => $text + }; + $self->{pbot}->{interpreter}->add_message_to_output_queue($to, $message, $delay); +} + +sub add_new_suggestions { + my ($self, $state) = @_; + + my $question = undef; + my $modified = 0; + + foreach my $player (@{$state->{players}}) { + if ($player->{deceived}) { + $self->{pbot}->{logger}->log("Adding new suggestion for $state->{current_question}->{id}: $state->{current_question}->{question}: $player->{deceived}\n"); + + if (not grep { lc $_ eq lc $player->{deceived} } @{$state->{current_question}->{suggestions}}) { + if (not defined $question) { + foreach my $q (@{$self->{questions}->{questions}}) { + if ($q->{id} == $state->{current_question}->{id}) { + $question = $q; + last; + } + } + } + + push @{$question->{suggestions}}, uc $player->{deceived}; + $modified = 1; + } + } } - if (not @{$self->{state_data}->{players}}) { - $self->send_message($self->{channel}, "All players have left the game!"); - $self->{current_state} = 'nogame'; - } - } + if ($modified) { $self->save_questions; } +} - my $state_data = $self->{state_data}; +sub run_one_state { + my $self = shift; - # this shouldn't happen - if (not defined $self->{current_state}) { - $self->{pbot}->{logger}->log("Spinach state broke.\n"); - $self->{current_state} = 'nogame'; - return; - } + # check for naughty or missing players + if ($self->{current_state} =~ /r\dq\d/) { + my $removed = 0; + for (my $i = 0; $i < @{$self->{state_data}->{players}}; $i++) { + if ($self->{state_data}->{players}->[$i]->{missedinputs} >= $self->{metadata}->get_data('settings', 'max_missed_inputs')) { + $self->send_message( + $self->{channel}, + "$color{red}$self->{state_data}->{players}->[$i]->{name} has missed too many prompts and has been ejected from the game!$color{reset}" + ); + splice @{$self->{state_data}->{players}}, $i--, 1; + $removed = 1; + } + } - # transistioned to a brand new state; prepare first tock - if ($self->{previous_state} ne $self->{current_state}) { - $state_data->{newstate} = 1; - $state_data->{ticks} = 1; + if ($removed) { + if ($self->{state_data}->{current_player} >= @{$self->{state_data}->{players}}) { $self->{state_data}->{current_player} = @{$self->{state_data}->{players}} - 1 } + } - if (exists $state_data->{tick_drift}) { - $state_data->{ticks} += $state_data->{tick_drift}; - delete $state_data->{tick_drift}; + if (not @{$self->{state_data}->{players}}) { + $self->send_message($self->{channel}, "All players have left the game!"); + $self->{current_state} = 'nogame'; + } } - $state_data->{first_tock} = 1; - } else { - $state_data->{newstate} = 0; - } + my $state_data = $self->{state_data}; - # dump new state data for logging/debugging - if ($state_data->{newstate} and $self->{metadata}->get_data('settings', 'debug_state')) { - $self->{pbot}->{logger}->log("Spinach: New state: $self->{previous_state} ($state_data->{previous_result}) --> $self->{current_state}\n" . Dumper $state_data); - } + # this shouldn't happen + if (not defined $self->{current_state}) { + $self->{pbot}->{logger}->log("Spinach state broke.\n"); + $self->{current_state} = 'nogame'; + return; + } - # run one state/tick - $state_data = $self->{states}{$self->{current_state}}{sub}($state_data); + # transistioned to a brand new state; prepare first tock + if ($self->{previous_state} ne $self->{current_state}) { + $state_data->{newstate} = 1; + $state_data->{ticks} = 1; - if ($state_data->{tocked}) { - delete $state_data->{tocked}; - delete $state_data->{first_tock}; - $state_data->{ticks} = 0; - } + if (exists $state_data->{tick_drift}) { + $state_data->{ticks} += $state_data->{tick_drift}; + delete $state_data->{tick_drift}; + } - # transform to next state - $state_data->{previous_result} = $state_data->{result}; - $self->{previous_state} = $self->{current_state}; + $state_data->{first_tock} = 1; + } else { + $state_data->{newstate} = 0; + } - if (not exists $self->{states}{$self->{current_state}}{trans}{$state_data->{result}}) { - $self->{pbot}->{logger}->log("Spinach: State broke: no such transistion to $state_data->{result} for state $self->{current_state}\n"); - # XXX: do something here - } + # dump new state data for logging/debugging + if ($state_data->{newstate} and $self->{metadata}->get_data('settings', 'debug_state')) { + $self->{pbot}->{logger}->log("Spinach: New state: $self->{previous_state} ($state_data->{previous_result}) --> $self->{current_state}\n" . Dumper $state_data); + } - $self->{current_state} = $self->{states}{$self->{current_state}}{trans}{$state_data->{result}}; - $self->{state_data} = $state_data; + # run one state/tick + $state_data = $self->{states}{$self->{current_state}}{sub}($state_data); - # next tick - $self->{state_data}->{ticks}++; + if ($state_data->{tocked}) { + delete $state_data->{tocked}; + delete $state_data->{first_tock}; + $state_data->{ticks} = 0; + } + + # transform to next state + $state_data->{previous_result} = $state_data->{result}; + $self->{previous_state} = $self->{current_state}; + + if (not exists $self->{states}{$self->{current_state}}{trans}{$state_data->{result}}) { + $self->{pbot}->{logger}->log("Spinach: State broke: no such transistion to $state_data->{result} for state $self->{current_state}\n"); + + # XXX: do something here + } + + $self->{current_state} = $self->{states}{$self->{current_state}}{trans}{$state_data->{result}}; + $self->{state_data} = $state_data; + + # next tick + $self->{state_data}->{ticks}++; } sub create_states { - my $self = shift; + my $self = shift; - $self->{pbot}->{logger}->log("Spinach: Creating game state machine\n"); + $self->{pbot}->{logger}->log("Spinach: Creating game state machine\n"); - $self->{previous_state} = ''; - $self->{previous_result} = ''; - $self->{current_state} = 'nogame'; - $self->{state_data} = { players => [], ticks => 0, newstate => 1 }; + $self->{previous_state} = ''; + $self->{previous_result} = ''; + $self->{current_state} = 'nogame'; + $self->{state_data} = {players => [], ticks => 0, newstate => 1}; + $self->{states}{'nogame'}{sub} = sub { $self->nogame(@_) }; + $self->{states}{'nogame'}{trans}{start} = 'getplayers'; + $self->{states}{'nogame'}{trans}{nogame} = 'nogame'; - $self->{states}{'nogame'}{sub} = sub { $self->nogame(@_) }; - $self->{states}{'nogame'}{trans}{start} = 'getplayers'; - $self->{states}{'nogame'}{trans}{nogame} = 'nogame'; + $self->{states}{'getplayers'}{sub} = sub { $self->getplayers(@_) }; + $self->{states}{'getplayers'}{trans}{stop} = 'nogame'; + $self->{states}{'getplayers'}{trans}{wait} = 'getplayers'; + $self->{states}{'getplayers'}{trans}{allready} = 'round1'; + $self->{states}{'round1'}{sub} = sub { $self->round1(@_) }; + $self->{states}{'round1'}{trans}{next} = 'round1q1'; - $self->{states}{'getplayers'}{sub} = sub { $self->getplayers(@_) }; - $self->{states}{'getplayers'}{trans}{stop} = 'nogame'; - $self->{states}{'getplayers'}{trans}{wait} = 'getplayers'; - $self->{states}{'getplayers'}{trans}{allready} = 'round1'; + $self->{states}{'round1q1'}{sub} = sub { $self->round1q1(@_) }; + $self->{states}{'round1q1'}{trans}{wait} = 'round1q1'; + $self->{states}{'round1q1'}{trans}{next} = 'r1q1choosecategory'; + $self->{states}{'r1q1choosecategory'}{sub} = sub { $self->r1q1choosecategory(@_) }; + $self->{states}{'r1q1choosecategory'}{trans}{wait} = 'r1q1choosecategory'; + $self->{states}{'r1q1choosecategory'}{trans}{next} = 'r1q1showquestion'; + $self->{states}{'r1q1showquestion'}{sub} = sub { $self->r1q1showquestion(@_) }; + $self->{states}{'r1q1showquestion'}{trans}{wait} = 'r1q1showquestion'; + $self->{states}{'r1q1showquestion'}{trans}{next} = 'r1q1getlies'; + $self->{states}{'r1q1getlies'}{sub} = sub { $self->r1q1getlies(@_) }; + $self->{states}{'r1q1getlies'}{trans}{reroll} = 'r1q1showquestion'; + $self->{states}{'r1q1getlies'}{trans}{skip} = 'round1q1'; + $self->{states}{'r1q1getlies'}{trans}{wait} = 'r1q1getlies'; + $self->{states}{'r1q1getlies'}{trans}{next} = 'r1q1findtruth'; + $self->{states}{'r1q1findtruth'}{sub} = sub { $self->r1q1findtruth(@_) }; + $self->{states}{'r1q1findtruth'}{trans}{wait} = 'r1q1findtruth'; + $self->{states}{'r1q1findtruth'}{trans}{next} = 'r1q1showlies'; + $self->{states}{'r1q1showlies'}{sub} = sub { $self->r1q1showlies(@_) }; + $self->{states}{'r1q1showlies'}{trans}{wait} = 'r1q1showlies'; + $self->{states}{'r1q1showlies'}{trans}{next} = 'r1q1showtruth'; + $self->{states}{'r1q1showtruth'}{sub} = sub { $self->r1q1showtruth(@_) }; + $self->{states}{'r1q1showtruth'}{trans}{wait} = 'r1q1showtruth'; + $self->{states}{'r1q1showtruth'}{trans}{next} = 'r1q1reveallies'; + $self->{states}{'r1q1reveallies'}{sub} = sub { $self->r1q1reveallies(@_) }; + $self->{states}{'r1q1reveallies'}{trans}{wait} = 'r1q1reveallies'; + $self->{states}{'r1q1reveallies'}{trans}{next} = 'r1q1showscore'; + $self->{states}{'r1q1showscore'}{sub} = sub { $self->r1q1showscore(@_) }; + $self->{states}{'r1q1showscore'}{trans}{wait} = 'r1q1showscore'; + $self->{states}{'r1q1showscore'}{trans}{next} = 'round1q2'; + $self->{states}{'round1q2'}{sub} = sub { $self->round1q2(@_) }; + $self->{states}{'round1q2'}{trans}{wait} = 'round1q2'; + $self->{states}{'round1q2'}{trans}{next} = 'r1q2choosecategory'; + $self->{states}{'r1q2choosecategory'}{sub} = sub { $self->r1q2choosecategory(@_) }; + $self->{states}{'r1q2choosecategory'}{trans}{wait} = 'r1q2choosecategory'; + $self->{states}{'r1q2choosecategory'}{trans}{next} = 'r1q2showquestion'; + $self->{states}{'r1q2showquestion'}{sub} = sub { $self->r1q2showquestion(@_) }; + $self->{states}{'r1q2showquestion'}{trans}{wait} = 'r1q2showquestion'; + $self->{states}{'r1q2showquestion'}{trans}{next} = 'r1q2getlies'; + $self->{states}{'r1q2getlies'}{sub} = sub { $self->r1q2getlies(@_) }; + $self->{states}{'r1q2getlies'}{trans}{reroll} = 'r1q2showquestion'; + $self->{states}{'r1q2getlies'}{trans}{skip} = 'round1q2'; + $self->{states}{'r1q2getlies'}{trans}{wait} = 'r1q2getlies'; + $self->{states}{'r1q2getlies'}{trans}{next} = 'r1q2findtruth'; + $self->{states}{'r1q2findtruth'}{sub} = sub { $self->r1q2findtruth(@_) }; + $self->{states}{'r1q2findtruth'}{trans}{wait} = 'r1q2findtruth'; + $self->{states}{'r1q2findtruth'}{trans}{next} = 'r1q2showlies'; + $self->{states}{'r1q2showlies'}{sub} = sub { $self->r1q2showlies(@_) }; + $self->{states}{'r1q2showlies'}{trans}{wait} = 'r1q2showlies'; + $self->{states}{'r1q2showlies'}{trans}{next} = 'r1q2showtruth'; + $self->{states}{'r1q2showtruth'}{sub} = sub { $self->r1q2showtruth(@_) }; + $self->{states}{'r1q2showtruth'}{trans}{wait} = 'r1q2showtruth'; + $self->{states}{'r1q2showtruth'}{trans}{next} = 'r1q2reveallies'; + $self->{states}{'r1q2reveallies'}{sub} = sub { $self->r1q2reveallies(@_) }; + $self->{states}{'r1q2reveallies'}{trans}{wait} = 'r1q2reveallies'; + $self->{states}{'r1q2reveallies'}{trans}{next} = 'r1q2showscore'; + $self->{states}{'r1q2showscore'}{sub} = sub { $self->r1q2showscore(@_) }; + $self->{states}{'r1q2showscore'}{trans}{wait} = 'r1q2showscore'; + $self->{states}{'r1q2showscore'}{trans}{next} = 'round1q3'; - $self->{states}{'round1'}{sub} = sub { $self->round1(@_) }; - $self->{states}{'round1'}{trans}{next} = 'round1q1'; + $self->{states}{'round1q3'}{sub} = sub { $self->round1q3(@_) }; + $self->{states}{'round1q3'}{trans}{next} = 'r1q3choosecategory'; + $self->{states}{'round1q3'}{trans}{wait} = 'round1q3'; + $self->{states}{'r1q3choosecategory'}{sub} = sub { $self->r1q3choosecategory(@_) }; + $self->{states}{'r1q3choosecategory'}{trans}{wait} = 'r1q3choosecategory'; + $self->{states}{'r1q3choosecategory'}{trans}{next} = 'r1q3showquestion'; + $self->{states}{'r1q3showquestion'}{sub} = sub { $self->r1q3showquestion(@_) }; + $self->{states}{'r1q3showquestion'}{trans}{wait} = 'r1q3showquestion'; + $self->{states}{'r1q3showquestion'}{trans}{next} = 'r1q3getlies'; + $self->{states}{'r1q3getlies'}{sub} = sub { $self->r1q3getlies(@_) }; + $self->{states}{'r1q3getlies'}{trans}{reroll} = 'r1q3showquestion'; + $self->{states}{'r1q3getlies'}{trans}{skip} = 'round1q3'; + $self->{states}{'r1q3getlies'}{trans}{wait} = 'r1q3getlies'; + $self->{states}{'r1q3getlies'}{trans}{next} = 'r1q3findtruth'; + $self->{states}{'r1q3findtruth'}{sub} = sub { $self->r1q3findtruth(@_) }; + $self->{states}{'r1q3findtruth'}{trans}{wait} = 'r1q3findtruth'; + $self->{states}{'r1q3findtruth'}{trans}{next} = 'r1q3showlies'; + $self->{states}{'r1q3showlies'}{sub} = sub { $self->r1q3showlies(@_) }; + $self->{states}{'r1q3showlies'}{trans}{wait} = 'r1q3showlies'; + $self->{states}{'r1q3showlies'}{trans}{next} = 'r1q3showtruth'; + $self->{states}{'r1q3showtruth'}{sub} = sub { $self->r1q3showtruth(@_) }; + $self->{states}{'r1q3showtruth'}{trans}{wait} = 'r1q3showtruth'; + $self->{states}{'r1q3showtruth'}{trans}{next} = 'r1q3reveallies'; + $self->{states}{'r1q3reveallies'}{sub} = sub { $self->r1q3reveallies(@_) }; + $self->{states}{'r1q3reveallies'}{trans}{wait} = 'r1q3reveallies'; + $self->{states}{'r1q3reveallies'}{trans}{next} = 'r1q3showscore'; + $self->{states}{'r1q3showscore'}{sub} = sub { $self->r1q3showscore(@_) }; + $self->{states}{'r1q3showscore'}{trans}{wait} = 'r1q3showscore'; + $self->{states}{'r1q3showscore'}{trans}{next} = 'round2'; - $self->{states}{'round1q1'}{sub} = sub { $self->round1q1(@_) }; - $self->{states}{'round1q1'}{trans}{wait} = 'round1q1'; - $self->{states}{'round1q1'}{trans}{next} = 'r1q1choosecategory'; - $self->{states}{'r1q1choosecategory'}{sub} = sub { $self->r1q1choosecategory(@_) }; - $self->{states}{'r1q1choosecategory'}{trans}{wait} = 'r1q1choosecategory'; - $self->{states}{'r1q1choosecategory'}{trans}{next} = 'r1q1showquestion'; - $self->{states}{'r1q1showquestion'}{sub} = sub { $self->r1q1showquestion(@_) }; - $self->{states}{'r1q1showquestion'}{trans}{wait} = 'r1q1showquestion'; - $self->{states}{'r1q1showquestion'}{trans}{next} = 'r1q1getlies'; - $self->{states}{'r1q1getlies'}{sub} = sub { $self->r1q1getlies(@_) }; - $self->{states}{'r1q1getlies'}{trans}{reroll} = 'r1q1showquestion'; - $self->{states}{'r1q1getlies'}{trans}{skip} = 'round1q1'; - $self->{states}{'r1q1getlies'}{trans}{wait} = 'r1q1getlies'; - $self->{states}{'r1q1getlies'}{trans}{next} = 'r1q1findtruth'; - $self->{states}{'r1q1findtruth'}{sub} = sub { $self->r1q1findtruth(@_) }; - $self->{states}{'r1q1findtruth'}{trans}{wait} = 'r1q1findtruth'; - $self->{states}{'r1q1findtruth'}{trans}{next} = 'r1q1showlies'; - $self->{states}{'r1q1showlies'}{sub} = sub { $self->r1q1showlies(@_) }; - $self->{states}{'r1q1showlies'}{trans}{wait} = 'r1q1showlies'; - $self->{states}{'r1q1showlies'}{trans}{next} = 'r1q1showtruth'; - $self->{states}{'r1q1showtruth'}{sub} = sub { $self->r1q1showtruth(@_) }; - $self->{states}{'r1q1showtruth'}{trans}{wait} = 'r1q1showtruth'; - $self->{states}{'r1q1showtruth'}{trans}{next} = 'r1q1reveallies'; - $self->{states}{'r1q1reveallies'}{sub} = sub { $self->r1q1reveallies(@_) }; - $self->{states}{'r1q1reveallies'}{trans}{wait} = 'r1q1reveallies'; - $self->{states}{'r1q1reveallies'}{trans}{next} = 'r1q1showscore'; - $self->{states}{'r1q1showscore'}{sub} = sub { $self->r1q1showscore(@_) }; - $self->{states}{'r1q1showscore'}{trans}{wait} = 'r1q1showscore'; - $self->{states}{'r1q1showscore'}{trans}{next} = 'round1q2'; + $self->{states}{'round2'}{sub} = sub { $self->round2(@_) }; + $self->{states}{'round2'}{trans}{next} = 'round2q1'; - $self->{states}{'round1q2'}{sub} = sub { $self->round1q2(@_) }; - $self->{states}{'round1q2'}{trans}{wait} = 'round1q2'; - $self->{states}{'round1q2'}{trans}{next} = 'r1q2choosecategory'; - $self->{states}{'r1q2choosecategory'}{sub} = sub { $self->r1q2choosecategory(@_) }; - $self->{states}{'r1q2choosecategory'}{trans}{wait} = 'r1q2choosecategory'; - $self->{states}{'r1q2choosecategory'}{trans}{next} = 'r1q2showquestion'; - $self->{states}{'r1q2showquestion'}{sub} = sub { $self->r1q2showquestion(@_) }; - $self->{states}{'r1q2showquestion'}{trans}{wait} = 'r1q2showquestion'; - $self->{states}{'r1q2showquestion'}{trans}{next} = 'r1q2getlies'; - $self->{states}{'r1q2getlies'}{sub} = sub { $self->r1q2getlies(@_) }; - $self->{states}{'r1q2getlies'}{trans}{reroll} = 'r1q2showquestion'; - $self->{states}{'r1q2getlies'}{trans}{skip} = 'round1q2'; - $self->{states}{'r1q2getlies'}{trans}{wait} = 'r1q2getlies'; - $self->{states}{'r1q2getlies'}{trans}{next} = 'r1q2findtruth'; - $self->{states}{'r1q2findtruth'}{sub} = sub { $self->r1q2findtruth(@_) }; - $self->{states}{'r1q2findtruth'}{trans}{wait} = 'r1q2findtruth'; - $self->{states}{'r1q2findtruth'}{trans}{next} = 'r1q2showlies'; - $self->{states}{'r1q2showlies'}{sub} = sub { $self->r1q2showlies(@_) }; - $self->{states}{'r1q2showlies'}{trans}{wait} = 'r1q2showlies'; - $self->{states}{'r1q2showlies'}{trans}{next} = 'r1q2showtruth'; - $self->{states}{'r1q2showtruth'}{sub} = sub { $self->r1q2showtruth(@_) }; - $self->{states}{'r1q2showtruth'}{trans}{wait} = 'r1q2showtruth'; - $self->{states}{'r1q2showtruth'}{trans}{next} = 'r1q2reveallies'; - $self->{states}{'r1q2reveallies'}{sub} = sub { $self->r1q2reveallies(@_) }; - $self->{states}{'r1q2reveallies'}{trans}{wait} = 'r1q2reveallies'; - $self->{states}{'r1q2reveallies'}{trans}{next} = 'r1q2showscore'; - $self->{states}{'r1q2showscore'}{sub} = sub { $self->r1q2showscore(@_) }; - $self->{states}{'r1q2showscore'}{trans}{wait} = 'r1q2showscore'; - $self->{states}{'r1q2showscore'}{trans}{next} = 'round1q3'; + $self->{states}{'round2q1'}{sub} = sub { $self->round2q1(@_) }; + $self->{states}{'round2q1'}{trans}{wait} = 'round2q1'; + $self->{states}{'round2q1'}{trans}{next} = 'r2q1choosecategory'; + $self->{states}{'r2q1choosecategory'}{sub} = sub { $self->r2q1choosecategory(@_) }; + $self->{states}{'r2q1choosecategory'}{trans}{wait} = 'r2q1choosecategory'; + $self->{states}{'r2q1choosecategory'}{trans}{next} = 'r2q1showquestion'; + $self->{states}{'r2q1showquestion'}{sub} = sub { $self->r2q1showquestion(@_) }; + $self->{states}{'r2q1showquestion'}{trans}{wait} = 'r2q1showquestion'; + $self->{states}{'r2q1showquestion'}{trans}{next} = 'r2q1getlies'; + $self->{states}{'r2q1getlies'}{sub} = sub { $self->r2q1getlies(@_) }; + $self->{states}{'r2q1getlies'}{trans}{reroll} = 'r2q1showquestion'; + $self->{states}{'r2q1getlies'}{trans}{skip} = 'round2q1'; + $self->{states}{'r2q1getlies'}{trans}{wait} = 'r2q1getlies'; + $self->{states}{'r2q1getlies'}{trans}{next} = 'r2q1findtruth'; + $self->{states}{'r2q1findtruth'}{sub} = sub { $self->r2q1findtruth(@_) }; + $self->{states}{'r2q1findtruth'}{trans}{wait} = 'r2q1findtruth'; + $self->{states}{'r2q1findtruth'}{trans}{next} = 'r2q1showlies'; + $self->{states}{'r2q1showlies'}{sub} = sub { $self->r2q1showlies(@_) }; + $self->{states}{'r2q1showlies'}{trans}{wait} = 'r2q1showlies'; + $self->{states}{'r2q1showlies'}{trans}{next} = 'r2q1showtruth'; + $self->{states}{'r2q1showtruth'}{sub} = sub { $self->r2q1showtruth(@_) }; + $self->{states}{'r2q1showtruth'}{trans}{wait} = 'r2q1showtruth'; + $self->{states}{'r2q1showtruth'}{trans}{next} = 'r2q1reveallies'; + $self->{states}{'r2q1reveallies'}{sub} = sub { $self->r2q1reveallies(@_) }; + $self->{states}{'r2q1reveallies'}{trans}{wait} = 'r2q1reveallies'; + $self->{states}{'r2q1reveallies'}{trans}{next} = 'r2q1showscore'; + $self->{states}{'r2q1showscore'}{sub} = sub { $self->r2q1showscore(@_) }; + $self->{states}{'r2q1showscore'}{trans}{wait} = 'r2q1showscore'; + $self->{states}{'r2q1showscore'}{trans}{next} = 'round2q2'; - $self->{states}{'round1q3'}{sub} = sub { $self->round1q3(@_) }; - $self->{states}{'round1q3'}{trans}{next} = 'r1q3choosecategory'; - $self->{states}{'round1q3'}{trans}{wait} = 'round1q3'; - $self->{states}{'r1q3choosecategory'}{sub} = sub { $self->r1q3choosecategory(@_) }; - $self->{states}{'r1q3choosecategory'}{trans}{wait} = 'r1q3choosecategory'; - $self->{states}{'r1q3choosecategory'}{trans}{next} = 'r1q3showquestion'; - $self->{states}{'r1q3showquestion'}{sub} = sub { $self->r1q3showquestion(@_) }; - $self->{states}{'r1q3showquestion'}{trans}{wait} = 'r1q3showquestion'; - $self->{states}{'r1q3showquestion'}{trans}{next} = 'r1q3getlies'; - $self->{states}{'r1q3getlies'}{sub} = sub { $self->r1q3getlies(@_) }; - $self->{states}{'r1q3getlies'}{trans}{reroll} = 'r1q3showquestion'; - $self->{states}{'r1q3getlies'}{trans}{skip} = 'round1q3'; - $self->{states}{'r1q3getlies'}{trans}{wait} = 'r1q3getlies'; - $self->{states}{'r1q3getlies'}{trans}{next} = 'r1q3findtruth'; - $self->{states}{'r1q3findtruth'}{sub} = sub { $self->r1q3findtruth(@_) }; - $self->{states}{'r1q3findtruth'}{trans}{wait} = 'r1q3findtruth'; - $self->{states}{'r1q3findtruth'}{trans}{next} = 'r1q3showlies'; - $self->{states}{'r1q3showlies'}{sub} = sub { $self->r1q3showlies(@_) }; - $self->{states}{'r1q3showlies'}{trans}{wait} = 'r1q3showlies'; - $self->{states}{'r1q3showlies'}{trans}{next} = 'r1q3showtruth'; - $self->{states}{'r1q3showtruth'}{sub} = sub { $self->r1q3showtruth(@_) }; - $self->{states}{'r1q3showtruth'}{trans}{wait} = 'r1q3showtruth'; - $self->{states}{'r1q3showtruth'}{trans}{next} = 'r1q3reveallies'; - $self->{states}{'r1q3reveallies'}{sub} = sub { $self->r1q3reveallies(@_) }; - $self->{states}{'r1q3reveallies'}{trans}{wait} = 'r1q3reveallies'; - $self->{states}{'r1q3reveallies'}{trans}{next} = 'r1q3showscore'; - $self->{states}{'r1q3showscore'}{sub} = sub { $self->r1q3showscore(@_) }; - $self->{states}{'r1q3showscore'}{trans}{wait} = 'r1q3showscore'; - $self->{states}{'r1q3showscore'}{trans}{next} = 'round2'; + $self->{states}{'round2q2'}{sub} = sub { $self->round2q2(@_) }; + $self->{states}{'round2q2'}{trans}{wait} = 'round2q2'; + $self->{states}{'round2q2'}{trans}{next} = 'r2q2choosecategory'; + $self->{states}{'r2q2choosecategory'}{sub} = sub { $self->r2q2choosecategory(@_) }; + $self->{states}{'r2q2choosecategory'}{trans}{wait} = 'r2q2choosecategory'; + $self->{states}{'r2q2choosecategory'}{trans}{next} = 'r2q2showquestion'; + $self->{states}{'r2q2showquestion'}{sub} = sub { $self->r2q2showquestion(@_) }; + $self->{states}{'r2q2showquestion'}{trans}{wait} = 'r2q2showquestion'; + $self->{states}{'r2q2showquestion'}{trans}{next} = 'r2q2getlies'; + $self->{states}{'r2q2getlies'}{sub} = sub { $self->r2q2getlies(@_) }; + $self->{states}{'r2q2getlies'}{trans}{reroll} = 'r2q2showquestion'; + $self->{states}{'r2q2getlies'}{trans}{skip} = 'round2q2'; + $self->{states}{'r2q2getlies'}{trans}{wait} = 'r2q2getlies'; + $self->{states}{'r2q2getlies'}{trans}{next} = 'r2q2findtruth'; + $self->{states}{'r2q2findtruth'}{sub} = sub { $self->r2q2findtruth(@_) }; + $self->{states}{'r2q2findtruth'}{trans}{wait} = 'r2q2findtruth'; + $self->{states}{'r2q2findtruth'}{trans}{next} = 'r2q2showlies'; + $self->{states}{'r2q2showlies'}{sub} = sub { $self->r2q2showlies(@_) }; + $self->{states}{'r2q2showlies'}{trans}{wait} = 'r2q2showlies'; + $self->{states}{'r2q2showlies'}{trans}{next} = 'r2q2showtruth'; + $self->{states}{'r2q2showtruth'}{sub} = sub { $self->r2q2showtruth(@_) }; + $self->{states}{'r2q2showtruth'}{trans}{wait} = 'r2q2showtruth'; + $self->{states}{'r2q2showtruth'}{trans}{next} = 'r2q2reveallies'; + $self->{states}{'r2q2reveallies'}{sub} = sub { $self->r2q2reveallies(@_) }; + $self->{states}{'r2q2reveallies'}{trans}{wait} = 'r2q2reveallies'; + $self->{states}{'r2q2reveallies'}{trans}{next} = 'r2q2showscore'; + $self->{states}{'r2q2showscore'}{sub} = sub { $self->r2q2showscore(@_) }; + $self->{states}{'r2q2showscore'}{trans}{wait} = 'r2q2showscore'; + $self->{states}{'r2q2showscore'}{trans}{next} = 'round2q3'; + $self->{states}{'round2q3'}{sub} = sub { $self->round2q3(@_) }; + $self->{states}{'round2q3'}{trans}{wait} = 'round2q3'; + $self->{states}{'round2q3'}{trans}{next} = 'r2q3choosecategory'; + $self->{states}{'r2q3choosecategory'}{sub} = sub { $self->r2q3choosecategory(@_) }; + $self->{states}{'r2q3choosecategory'}{trans}{wait} = 'r2q3choosecategory'; + $self->{states}{'r2q3choosecategory'}{trans}{next} = 'r2q3showquestion'; + $self->{states}{'r2q3showquestion'}{sub} = sub { $self->r2q3showquestion(@_) }; + $self->{states}{'r2q3showquestion'}{trans}{wait} = 'r2q3showquestion'; + $self->{states}{'r2q3showquestion'}{trans}{next} = 'r2q3getlies'; + $self->{states}{'r2q3getlies'}{sub} = sub { $self->r2q3getlies(@_) }; + $self->{states}{'r2q3getlies'}{trans}{reroll} = 'r2q3showquestion'; + $self->{states}{'r2q3getlies'}{trans}{skip} = 'round2q3'; + $self->{states}{'r2q3getlies'}{trans}{wait} = 'r2q3getlies'; + $self->{states}{'r2q3getlies'}{trans}{next} = 'r2q3findtruth'; + $self->{states}{'r2q3findtruth'}{sub} = sub { $self->r2q3findtruth(@_) }; + $self->{states}{'r2q3findtruth'}{trans}{wait} = 'r2q3findtruth'; + $self->{states}{'r2q3findtruth'}{trans}{next} = 'r2q3showlies'; + $self->{states}{'r2q3showlies'}{sub} = sub { $self->r2q3showlies(@_) }; + $self->{states}{'r2q3showlies'}{trans}{wait} = 'r2q3showlies'; + $self->{states}{'r2q3showlies'}{trans}{next} = 'r2q3showtruth'; + $self->{states}{'r2q3showtruth'}{sub} = sub { $self->r2q3showtruth(@_) }; + $self->{states}{'r2q3showtruth'}{trans}{wait} = 'r2q3showtruth'; + $self->{states}{'r2q3showtruth'}{trans}{next} = 'r2q3reveallies'; + $self->{states}{'r2q3reveallies'}{sub} = sub { $self->r2q3reveallies(@_) }; + $self->{states}{'r2q3reveallies'}{trans}{wait} = 'r2q3reveallies'; + $self->{states}{'r2q3reveallies'}{trans}{next} = 'r2q3showscore'; + $self->{states}{'r2q3showscore'}{sub} = sub { $self->r2q3showscore(@_) }; + $self->{states}{'r2q3showscore'}{trans}{wait} = 'r2q3showscore'; + $self->{states}{'r2q3showscore'}{trans}{next} = 'round3'; - $self->{states}{'round2'}{sub} = sub { $self->round2(@_) }; - $self->{states}{'round2'}{trans}{next} = 'round2q1'; + $self->{states}{'round3'}{sub} = sub { $self->round3(@_) }; + $self->{states}{'round3'}{trans}{next} = 'round3q1'; - $self->{states}{'round2q1'}{sub} = sub { $self->round2q1(@_) }; - $self->{states}{'round2q1'}{trans}{wait} = 'round2q1'; - $self->{states}{'round2q1'}{trans}{next} = 'r2q1choosecategory'; - $self->{states}{'r2q1choosecategory'}{sub} = sub { $self->r2q1choosecategory(@_) }; - $self->{states}{'r2q1choosecategory'}{trans}{wait} = 'r2q1choosecategory'; - $self->{states}{'r2q1choosecategory'}{trans}{next} = 'r2q1showquestion'; - $self->{states}{'r2q1showquestion'}{sub} = sub { $self->r2q1showquestion(@_) }; - $self->{states}{'r2q1showquestion'}{trans}{wait} = 'r2q1showquestion'; - $self->{states}{'r2q1showquestion'}{trans}{next} = 'r2q1getlies'; - $self->{states}{'r2q1getlies'}{sub} = sub { $self->r2q1getlies(@_) }; - $self->{states}{'r2q1getlies'}{trans}{reroll} = 'r2q1showquestion'; - $self->{states}{'r2q1getlies'}{trans}{skip} = 'round2q1'; - $self->{states}{'r2q1getlies'}{trans}{wait} = 'r2q1getlies'; - $self->{states}{'r2q1getlies'}{trans}{next} = 'r2q1findtruth'; - $self->{states}{'r2q1findtruth'}{sub} = sub { $self->r2q1findtruth(@_) }; - $self->{states}{'r2q1findtruth'}{trans}{wait} = 'r2q1findtruth'; - $self->{states}{'r2q1findtruth'}{trans}{next} = 'r2q1showlies'; - $self->{states}{'r2q1showlies'}{sub} = sub { $self->r2q1showlies(@_) }; - $self->{states}{'r2q1showlies'}{trans}{wait} = 'r2q1showlies'; - $self->{states}{'r2q1showlies'}{trans}{next} = 'r2q1showtruth'; - $self->{states}{'r2q1showtruth'}{sub} = sub { $self->r2q1showtruth(@_) }; - $self->{states}{'r2q1showtruth'}{trans}{wait} = 'r2q1showtruth'; - $self->{states}{'r2q1showtruth'}{trans}{next} = 'r2q1reveallies'; - $self->{states}{'r2q1reveallies'}{sub} = sub { $self->r2q1reveallies(@_) }; - $self->{states}{'r2q1reveallies'}{trans}{wait} = 'r2q1reveallies'; - $self->{states}{'r2q1reveallies'}{trans}{next} = 'r2q1showscore'; - $self->{states}{'r2q1showscore'}{sub} = sub { $self->r2q1showscore(@_) }; - $self->{states}{'r2q1showscore'}{trans}{wait} = 'r2q1showscore'; - $self->{states}{'r2q1showscore'}{trans}{next} = 'round2q2'; + $self->{states}{'round3q1'}{sub} = sub { $self->round3q1(@_) }; + $self->{states}{'round3q1'}{trans}{wait} = 'round3q1'; + $self->{states}{'round3q1'}{trans}{next} = 'r3q1choosecategory'; + $self->{states}{'r3q1choosecategory'}{sub} = sub { $self->r3q1choosecategory(@_) }; + $self->{states}{'r3q1choosecategory'}{trans}{wait} = 'r3q1choosecategory'; + $self->{states}{'r3q1choosecategory'}{trans}{next} = 'r3q1showquestion'; + $self->{states}{'r3q1showquestion'}{sub} = sub { $self->r3q1showquestion(@_) }; + $self->{states}{'r3q1showquestion'}{trans}{wait} = 'r3q1showquestion'; + $self->{states}{'r3q1showquestion'}{trans}{next} = 'r3q1getlies'; + $self->{states}{'r3q1getlies'}{sub} = sub { $self->r3q1getlies(@_) }; + $self->{states}{'r3q1getlies'}{trans}{reroll} = 'r3q1showquestion'; + $self->{states}{'r3q1getlies'}{trans}{skip} = 'round3q1'; + $self->{states}{'r3q1getlies'}{trans}{wait} = 'r3q1getlies'; + $self->{states}{'r3q1getlies'}{trans}{next} = 'r3q1findtruth'; + $self->{states}{'r3q1findtruth'}{sub} = sub { $self->r3q1findtruth(@_) }; + $self->{states}{'r3q1findtruth'}{trans}{wait} = 'r3q1findtruth'; + $self->{states}{'r3q1findtruth'}{trans}{next} = 'r3q1showlies'; + $self->{states}{'r3q1showlies'}{sub} = sub { $self->r3q1showlies(@_) }; + $self->{states}{'r3q1showlies'}{trans}{wait} = 'r3q1showlies'; + $self->{states}{'r3q1showlies'}{trans}{next} = 'r3q1showtruth'; + $self->{states}{'r3q1showtruth'}{sub} = sub { $self->r3q1showtruth(@_) }; + $self->{states}{'r3q1showtruth'}{trans}{wait} = 'r3q1showtruth'; + $self->{states}{'r3q1showtruth'}{trans}{next} = 'r3q1reveallies'; + $self->{states}{'r3q1reveallies'}{sub} = sub { $self->r3q1reveallies(@_) }; + $self->{states}{'r3q1reveallies'}{trans}{wait} = 'r3q1reveallies'; + $self->{states}{'r3q1reveallies'}{trans}{next} = 'r3q1showscore'; + $self->{states}{'r3q1showscore'}{sub} = sub { $self->r3q1showscore(@_) }; + $self->{states}{'r3q1showscore'}{trans}{wait} = 'r3q1showscore'; + $self->{states}{'r3q1showscore'}{trans}{next} = 'round3q2'; - $self->{states}{'round2q2'}{sub} = sub { $self->round2q2(@_) }; - $self->{states}{'round2q2'}{trans}{wait} = 'round2q2'; - $self->{states}{'round2q2'}{trans}{next} = 'r2q2choosecategory'; - $self->{states}{'r2q2choosecategory'}{sub} = sub { $self->r2q2choosecategory(@_) }; - $self->{states}{'r2q2choosecategory'}{trans}{wait} = 'r2q2choosecategory'; - $self->{states}{'r2q2choosecategory'}{trans}{next} = 'r2q2showquestion'; - $self->{states}{'r2q2showquestion'}{sub} = sub { $self->r2q2showquestion(@_) }; - $self->{states}{'r2q2showquestion'}{trans}{wait} = 'r2q2showquestion'; - $self->{states}{'r2q2showquestion'}{trans}{next} = 'r2q2getlies'; - $self->{states}{'r2q2getlies'}{sub} = sub { $self->r2q2getlies(@_) }; - $self->{states}{'r2q2getlies'}{trans}{reroll} = 'r2q2showquestion'; - $self->{states}{'r2q2getlies'}{trans}{skip} = 'round2q2'; - $self->{states}{'r2q2getlies'}{trans}{wait} = 'r2q2getlies'; - $self->{states}{'r2q2getlies'}{trans}{next} = 'r2q2findtruth'; - $self->{states}{'r2q2findtruth'}{sub} = sub { $self->r2q2findtruth(@_) }; - $self->{states}{'r2q2findtruth'}{trans}{wait} = 'r2q2findtruth'; - $self->{states}{'r2q2findtruth'}{trans}{next} = 'r2q2showlies'; - $self->{states}{'r2q2showlies'}{sub} = sub { $self->r2q2showlies(@_) }; - $self->{states}{'r2q2showlies'}{trans}{wait} = 'r2q2showlies'; - $self->{states}{'r2q2showlies'}{trans}{next} = 'r2q2showtruth'; - $self->{states}{'r2q2showtruth'}{sub} = sub { $self->r2q2showtruth(@_) }; - $self->{states}{'r2q2showtruth'}{trans}{wait} = 'r2q2showtruth'; - $self->{states}{'r2q2showtruth'}{trans}{next} = 'r2q2reveallies'; - $self->{states}{'r2q2reveallies'}{sub} = sub { $self->r2q2reveallies(@_) }; - $self->{states}{'r2q2reveallies'}{trans}{wait} = 'r2q2reveallies'; - $self->{states}{'r2q2reveallies'}{trans}{next} = 'r2q2showscore'; - $self->{states}{'r2q2showscore'}{sub} = sub { $self->r2q2showscore(@_) }; - $self->{states}{'r2q2showscore'}{trans}{wait} = 'r2q2showscore'; - $self->{states}{'r2q2showscore'}{trans}{next} = 'round2q3'; + $self->{states}{'round3q2'}{sub} = sub { $self->round3q2(@_) }; + $self->{states}{'round3q2'}{trans}{wait} = 'round3q2'; + $self->{states}{'round3q2'}{trans}{next} = 'r3q2choosecategory'; + $self->{states}{'r3q2choosecategory'}{sub} = sub { $self->r3q2choosecategory(@_) }; + $self->{states}{'r3q2choosecategory'}{trans}{wait} = 'r3q2choosecategory'; + $self->{states}{'r3q2choosecategory'}{trans}{next} = 'r3q2showquestion'; + $self->{states}{'r3q2showquestion'}{sub} = sub { $self->r3q2showquestion(@_) }; + $self->{states}{'r3q2showquestion'}{trans}{wait} = 'r3q2showquestion'; + $self->{states}{'r3q2showquestion'}{trans}{next} = 'r3q2getlies'; + $self->{states}{'r3q2getlies'}{sub} = sub { $self->r3q2getlies(@_) }; + $self->{states}{'r3q2getlies'}{trans}{reroll} = 'r3q2showquestion'; + $self->{states}{'r3q2getlies'}{trans}{skip} = 'round3q2'; + $self->{states}{'r3q2getlies'}{trans}{wait} = 'r3q2getlies'; + $self->{states}{'r3q2getlies'}{trans}{next} = 'r3q2findtruth'; + $self->{states}{'r3q2findtruth'}{sub} = sub { $self->r3q2findtruth(@_) }; + $self->{states}{'r3q2findtruth'}{trans}{wait} = 'r3q2findtruth'; + $self->{states}{'r3q2findtruth'}{trans}{next} = 'r3q2showlies'; + $self->{states}{'r3q2showlies'}{sub} = sub { $self->r3q2showlies(@_) }; + $self->{states}{'r3q2showlies'}{trans}{wait} = 'r3q2showlies'; + $self->{states}{'r3q2showlies'}{trans}{next} = 'r3q2showtruth'; + $self->{states}{'r3q2showtruth'}{sub} = sub { $self->r3q2showtruth(@_) }; + $self->{states}{'r3q2showtruth'}{trans}{wait} = 'r3q2showtruth'; + $self->{states}{'r3q2showtruth'}{trans}{next} = 'r3q2reveallies'; + $self->{states}{'r3q2reveallies'}{sub} = sub { $self->r3q2reveallies(@_) }; + $self->{states}{'r3q2reveallies'}{trans}{wait} = 'r3q2reveallies'; + $self->{states}{'r3q2reveallies'}{trans}{next} = 'r3q2showscore'; + $self->{states}{'r3q2showscore'}{sub} = sub { $self->r3q2showscore(@_) }; + $self->{states}{'r3q2showscore'}{trans}{wait} = 'r3q2showscore'; + $self->{states}{'r3q2showscore'}{trans}{next} = 'round3q3'; - $self->{states}{'round2q3'}{sub} = sub { $self->round2q3(@_) }; - $self->{states}{'round2q3'}{trans}{wait} = 'round2q3'; - $self->{states}{'round2q3'}{trans}{next} = 'r2q3choosecategory'; - $self->{states}{'r2q3choosecategory'}{sub} = sub { $self->r2q3choosecategory(@_) }; - $self->{states}{'r2q3choosecategory'}{trans}{wait} = 'r2q3choosecategory'; - $self->{states}{'r2q3choosecategory'}{trans}{next} = 'r2q3showquestion'; - $self->{states}{'r2q3showquestion'}{sub} = sub { $self->r2q3showquestion(@_) }; - $self->{states}{'r2q3showquestion'}{trans}{wait} = 'r2q3showquestion'; - $self->{states}{'r2q3showquestion'}{trans}{next} = 'r2q3getlies'; - $self->{states}{'r2q3getlies'}{sub} = sub { $self->r2q3getlies(@_) }; - $self->{states}{'r2q3getlies'}{trans}{reroll} = 'r2q3showquestion'; - $self->{states}{'r2q3getlies'}{trans}{skip} = 'round2q3'; - $self->{states}{'r2q3getlies'}{trans}{wait} = 'r2q3getlies'; - $self->{states}{'r2q3getlies'}{trans}{next} = 'r2q3findtruth'; - $self->{states}{'r2q3findtruth'}{sub} = sub { $self->r2q3findtruth(@_) }; - $self->{states}{'r2q3findtruth'}{trans}{wait} = 'r2q3findtruth'; - $self->{states}{'r2q3findtruth'}{trans}{next} = 'r2q3showlies'; - $self->{states}{'r2q3showlies'}{sub} = sub { $self->r2q3showlies(@_) }; - $self->{states}{'r2q3showlies'}{trans}{wait} = 'r2q3showlies'; - $self->{states}{'r2q3showlies'}{trans}{next} = 'r2q3showtruth'; - $self->{states}{'r2q3showtruth'}{sub} = sub { $self->r2q3showtruth(@_) }; - $self->{states}{'r2q3showtruth'}{trans}{wait} = 'r2q3showtruth'; - $self->{states}{'r2q3showtruth'}{trans}{next} = 'r2q3reveallies'; - $self->{states}{'r2q3reveallies'}{sub} = sub { $self->r2q3reveallies(@_) }; - $self->{states}{'r2q3reveallies'}{trans}{wait} = 'r2q3reveallies'; - $self->{states}{'r2q3reveallies'}{trans}{next} = 'r2q3showscore'; - $self->{states}{'r2q3showscore'}{sub} = sub { $self->r2q3showscore(@_) }; - $self->{states}{'r2q3showscore'}{trans}{wait} = 'r2q3showscore'; - $self->{states}{'r2q3showscore'}{trans}{next} = 'round3'; + $self->{states}{'round3q3'}{sub} = sub { $self->round3q3(@_) }; + $self->{states}{'round3q3'}{trans}{wait} = 'round3q3'; + $self->{states}{'round3q3'}{trans}{next} = 'r3q3choosecategory'; + $self->{states}{'r3q3choosecategory'}{sub} = sub { $self->r3q3choosecategory(@_) }; + $self->{states}{'r3q3choosecategory'}{trans}{wait} = 'r3q3choosecategory'; + $self->{states}{'r3q3choosecategory'}{trans}{next} = 'r3q3showquestion'; + $self->{states}{'r3q3showquestion'}{sub} = sub { $self->r3q3showquestion(@_) }; + $self->{states}{'r3q3showquestion'}{trans}{wait} = 'r3q3showquestion'; + $self->{states}{'r3q3showquestion'}{trans}{next} = 'r3q3getlies'; + $self->{states}{'r3q3getlies'}{sub} = sub { $self->r3q3getlies(@_) }; + $self->{states}{'r3q3getlies'}{trans}{reroll} = 'r3q3showquestion'; + $self->{states}{'r3q3getlies'}{trans}{skip} = 'round3q3'; + $self->{states}{'r3q3getlies'}{trans}{wait} = 'r3q3getlies'; + $self->{states}{'r3q3getlies'}{trans}{next} = 'r3q3findtruth'; + $self->{states}{'r3q3findtruth'}{sub} = sub { $self->r3q3findtruth(@_) }; + $self->{states}{'r3q3findtruth'}{trans}{wait} = 'r3q3findtruth'; + $self->{states}{'r3q3findtruth'}{trans}{next} = 'r3q3showlies'; + $self->{states}{'r3q3showlies'}{sub} = sub { $self->r3q3showlies(@_) }; + $self->{states}{'r3q3showlies'}{trans}{wait} = 'r3q3showlies'; + $self->{states}{'r3q3showlies'}{trans}{next} = 'r3q3showtruth'; + $self->{states}{'r3q3showtruth'}{sub} = sub { $self->r3q3showtruth(@_) }; + $self->{states}{'r3q3showtruth'}{trans}{wait} = 'r3q3showtruth'; + $self->{states}{'r3q3showtruth'}{trans}{next} = 'r3q3reveallies'; + $self->{states}{'r3q3reveallies'}{sub} = sub { $self->r3q3reveallies(@_) }; + $self->{states}{'r3q3reveallies'}{trans}{wait} = 'r3q3reveallies'; + $self->{states}{'r3q3reveallies'}{trans}{next} = 'r3q3showscore'; + $self->{states}{'r3q3showscore'}{sub} = sub { $self->r3q3showscore(@_) }; + $self->{states}{'r3q3showscore'}{trans}{wait} = 'r3q3showscore'; + $self->{states}{'r3q3showscore'}{trans}{next} = 'round4'; + $self->{states}{'round4'}{sub} = sub { $self->round4(@_) }; + $self->{states}{'round4'}{trans}{next} = 'round4q1'; - $self->{states}{'round3'}{sub} = sub { $self->round3(@_) }; - $self->{states}{'round3'}{trans}{next} = 'round3q1'; + $self->{states}{'round4q1'}{sub} = sub { $self->round4q1(@_) }; + $self->{states}{'round4q1'}{trans}{wait} = 'round4q1'; + $self->{states}{'round4q1'}{trans}{next} = 'r4q1choosecategory'; + $self->{states}{'r4q1choosecategory'}{sub} = sub { $self->r4q1choosecategory(@_) }; + $self->{states}{'r4q1choosecategory'}{trans}{wait} = 'r4q1choosecategory'; + $self->{states}{'r4q1choosecategory'}{trans}{next} = 'r4q1showquestion'; + $self->{states}{'r4q1showquestion'}{sub} = sub { $self->r4q1showquestion(@_) }; + $self->{states}{'r4q1showquestion'}{trans}{wait} = 'r4q1showquestion'; + $self->{states}{'r4q1showquestion'}{trans}{next} = 'r4q1getlies'; + $self->{states}{'r4q1getlies'}{sub} = sub { $self->r4q1getlies(@_) }; + $self->{states}{'r4q1getlies'}{trans}{reroll} = 'r4q1showquestion'; + $self->{states}{'r4q1getlies'}{trans}{skip} = 'round4q1'; + $self->{states}{'r4q1getlies'}{trans}{wait} = 'r4q1getlies'; + $self->{states}{'r4q1getlies'}{trans}{next} = 'r4q1findtruth'; + $self->{states}{'r4q1findtruth'}{sub} = sub { $self->r4q1findtruth(@_) }; + $self->{states}{'r4q1findtruth'}{trans}{wait} = 'r4q1findtruth'; + $self->{states}{'r4q1findtruth'}{trans}{next} = 'r4q1showlies'; + $self->{states}{'r4q1showlies'}{sub} = sub { $self->r4q1showlies(@_) }; + $self->{states}{'r4q1showlies'}{trans}{wait} = 'r4q1showlies'; + $self->{states}{'r4q1showlies'}{trans}{next} = 'r4q1showtruth'; + $self->{states}{'r4q1showtruth'}{sub} = sub { $self->r4q1showtruth(@_) }; + $self->{states}{'r4q1showtruth'}{trans}{wait} = 'r4q1showtruth'; + $self->{states}{'r4q1showtruth'}{trans}{next} = 'r4q1reveallies'; + $self->{states}{'r4q1reveallies'}{sub} = sub { $self->r4q1reveallies(@_) }; + $self->{states}{'r4q1reveallies'}{trans}{wait} = 'r4q1reveallies'; + $self->{states}{'r4q1reveallies'}{trans}{next} = 'r4q1showscore'; + $self->{states}{'r4q1showscore'}{sub} = sub { $self->r4q1showscore(@_) }; + $self->{states}{'r4q1showscore'}{trans}{wait} = 'r4q1showscore'; + $self->{states}{'r4q1showscore'}{trans}{next} = 'gameover'; - $self->{states}{'round3q1'}{sub} = sub { $self->round3q1(@_) }; - $self->{states}{'round3q1'}{trans}{wait} = 'round3q1'; - $self->{states}{'round3q1'}{trans}{next} = 'r3q1choosecategory'; - $self->{states}{'r3q1choosecategory'}{sub} = sub { $self->r3q1choosecategory(@_) }; - $self->{states}{'r3q1choosecategory'}{trans}{wait} = 'r3q1choosecategory'; - $self->{states}{'r3q1choosecategory'}{trans}{next} = 'r3q1showquestion'; - $self->{states}{'r3q1showquestion'}{sub} = sub { $self->r3q1showquestion(@_) }; - $self->{states}{'r3q1showquestion'}{trans}{wait} = 'r3q1showquestion'; - $self->{states}{'r3q1showquestion'}{trans}{next} = 'r3q1getlies'; - $self->{states}{'r3q1getlies'}{sub} = sub { $self->r3q1getlies(@_) }; - $self->{states}{'r3q1getlies'}{trans}{reroll} = 'r3q1showquestion'; - $self->{states}{'r3q1getlies'}{trans}{skip} = 'round3q1'; - $self->{states}{'r3q1getlies'}{trans}{wait} = 'r3q1getlies'; - $self->{states}{'r3q1getlies'}{trans}{next} = 'r3q1findtruth'; - $self->{states}{'r3q1findtruth'}{sub} = sub { $self->r3q1findtruth(@_) }; - $self->{states}{'r3q1findtruth'}{trans}{wait} = 'r3q1findtruth'; - $self->{states}{'r3q1findtruth'}{trans}{next} = 'r3q1showlies'; - $self->{states}{'r3q1showlies'}{sub} = sub { $self->r3q1showlies(@_) }; - $self->{states}{'r3q1showlies'}{trans}{wait} = 'r3q1showlies'; - $self->{states}{'r3q1showlies'}{trans}{next} = 'r3q1showtruth'; - $self->{states}{'r3q1showtruth'}{sub} = sub { $self->r3q1showtruth(@_) }; - $self->{states}{'r3q1showtruth'}{trans}{wait} = 'r3q1showtruth'; - $self->{states}{'r3q1showtruth'}{trans}{next} = 'r3q1reveallies'; - $self->{states}{'r3q1reveallies'}{sub} = sub { $self->r3q1reveallies(@_) }; - $self->{states}{'r3q1reveallies'}{trans}{wait} = 'r3q1reveallies'; - $self->{states}{'r3q1reveallies'}{trans}{next} = 'r3q1showscore'; - $self->{states}{'r3q1showscore'}{sub} = sub { $self->r3q1showscore(@_) }; - $self->{states}{'r3q1showscore'}{trans}{wait} = 'r3q1showscore'; - $self->{states}{'r3q1showscore'}{trans}{next} = 'round3q2'; - - $self->{states}{'round3q2'}{sub} = sub { $self->round3q2(@_) }; - $self->{states}{'round3q2'}{trans}{wait} = 'round3q2'; - $self->{states}{'round3q2'}{trans}{next} = 'r3q2choosecategory'; - $self->{states}{'r3q2choosecategory'}{sub} = sub { $self->r3q2choosecategory(@_) }; - $self->{states}{'r3q2choosecategory'}{trans}{wait} = 'r3q2choosecategory'; - $self->{states}{'r3q2choosecategory'}{trans}{next} = 'r3q2showquestion'; - $self->{states}{'r3q2showquestion'}{sub} = sub { $self->r3q2showquestion(@_) }; - $self->{states}{'r3q2showquestion'}{trans}{wait} = 'r3q2showquestion'; - $self->{states}{'r3q2showquestion'}{trans}{next} = 'r3q2getlies'; - $self->{states}{'r3q2getlies'}{sub} = sub { $self->r3q2getlies(@_) }; - $self->{states}{'r3q2getlies'}{trans}{reroll} = 'r3q2showquestion'; - $self->{states}{'r3q2getlies'}{trans}{skip} = 'round3q2'; - $self->{states}{'r3q2getlies'}{trans}{wait} = 'r3q2getlies'; - $self->{states}{'r3q2getlies'}{trans}{next} = 'r3q2findtruth'; - $self->{states}{'r3q2findtruth'}{sub} = sub { $self->r3q2findtruth(@_) }; - $self->{states}{'r3q2findtruth'}{trans}{wait} = 'r3q2findtruth'; - $self->{states}{'r3q2findtruth'}{trans}{next} = 'r3q2showlies'; - $self->{states}{'r3q2showlies'}{sub} = sub { $self->r3q2showlies(@_) }; - $self->{states}{'r3q2showlies'}{trans}{wait} = 'r3q2showlies'; - $self->{states}{'r3q2showlies'}{trans}{next} = 'r3q2showtruth'; - $self->{states}{'r3q2showtruth'}{sub} = sub { $self->r3q2showtruth(@_) }; - $self->{states}{'r3q2showtruth'}{trans}{wait} = 'r3q2showtruth'; - $self->{states}{'r3q2showtruth'}{trans}{next} = 'r3q2reveallies'; - $self->{states}{'r3q2reveallies'}{sub} = sub { $self->r3q2reveallies(@_) }; - $self->{states}{'r3q2reveallies'}{trans}{wait} = 'r3q2reveallies'; - $self->{states}{'r3q2reveallies'}{trans}{next} = 'r3q2showscore'; - $self->{states}{'r3q2showscore'}{sub} = sub { $self->r3q2showscore(@_) }; - $self->{states}{'r3q2showscore'}{trans}{wait} = 'r3q2showscore'; - $self->{states}{'r3q2showscore'}{trans}{next} = 'round3q3'; - - $self->{states}{'round3q3'}{sub} = sub { $self->round3q3(@_) }; - $self->{states}{'round3q3'}{trans}{wait} = 'round3q3'; - $self->{states}{'round3q3'}{trans}{next} = 'r3q3choosecategory'; - $self->{states}{'r3q3choosecategory'}{sub} = sub { $self->r3q3choosecategory(@_) }; - $self->{states}{'r3q3choosecategory'}{trans}{wait} = 'r3q3choosecategory'; - $self->{states}{'r3q3choosecategory'}{trans}{next} = 'r3q3showquestion'; - $self->{states}{'r3q3showquestion'}{sub} = sub { $self->r3q3showquestion(@_) }; - $self->{states}{'r3q3showquestion'}{trans}{wait} = 'r3q3showquestion'; - $self->{states}{'r3q3showquestion'}{trans}{next} = 'r3q3getlies'; - $self->{states}{'r3q3getlies'}{sub} = sub { $self->r3q3getlies(@_) }; - $self->{states}{'r3q3getlies'}{trans}{reroll} = 'r3q3showquestion'; - $self->{states}{'r3q3getlies'}{trans}{skip} = 'round3q3'; - $self->{states}{'r3q3getlies'}{trans}{wait} = 'r3q3getlies'; - $self->{states}{'r3q3getlies'}{trans}{next} = 'r3q3findtruth'; - $self->{states}{'r3q3findtruth'}{sub} = sub { $self->r3q3findtruth(@_) }; - $self->{states}{'r3q3findtruth'}{trans}{wait} = 'r3q3findtruth'; - $self->{states}{'r3q3findtruth'}{trans}{next} = 'r3q3showlies'; - $self->{states}{'r3q3showlies'}{sub} = sub { $self->r3q3showlies(@_) }; - $self->{states}{'r3q3showlies'}{trans}{wait} = 'r3q3showlies'; - $self->{states}{'r3q3showlies'}{trans}{next} = 'r3q3showtruth'; - $self->{states}{'r3q3showtruth'}{sub} = sub { $self->r3q3showtruth(@_) }; - $self->{states}{'r3q3showtruth'}{trans}{wait} = 'r3q3showtruth'; - $self->{states}{'r3q3showtruth'}{trans}{next} = 'r3q3reveallies'; - $self->{states}{'r3q3reveallies'}{sub} = sub { $self->r3q3reveallies(@_) }; - $self->{states}{'r3q3reveallies'}{trans}{wait} = 'r3q3reveallies'; - $self->{states}{'r3q3reveallies'}{trans}{next} = 'r3q3showscore'; - $self->{states}{'r3q3showscore'}{sub} = sub { $self->r3q3showscore(@_) }; - $self->{states}{'r3q3showscore'}{trans}{wait} = 'r3q3showscore'; - $self->{states}{'r3q3showscore'}{trans}{next} = 'round4'; - - - $self->{states}{'round4'}{sub} = sub { $self->round4(@_) }; - $self->{states}{'round4'}{trans}{next} = 'round4q1'; - - $self->{states}{'round4q1'}{sub} = sub { $self->round4q1(@_) }; - $self->{states}{'round4q1'}{trans}{wait} = 'round4q1'; - $self->{states}{'round4q1'}{trans}{next} = 'r4q1choosecategory'; - $self->{states}{'r4q1choosecategory'}{sub} = sub { $self->r4q1choosecategory(@_) }; - $self->{states}{'r4q1choosecategory'}{trans}{wait} = 'r4q1choosecategory'; - $self->{states}{'r4q1choosecategory'}{trans}{next} = 'r4q1showquestion'; - $self->{states}{'r4q1showquestion'}{sub} = sub { $self->r4q1showquestion(@_) }; - $self->{states}{'r4q1showquestion'}{trans}{wait} = 'r4q1showquestion'; - $self->{states}{'r4q1showquestion'}{trans}{next} = 'r4q1getlies'; - $self->{states}{'r4q1getlies'}{sub} = sub { $self->r4q1getlies(@_) }; - $self->{states}{'r4q1getlies'}{trans}{reroll} = 'r4q1showquestion'; - $self->{states}{'r4q1getlies'}{trans}{skip} = 'round4q1'; - $self->{states}{'r4q1getlies'}{trans}{wait} = 'r4q1getlies'; - $self->{states}{'r4q1getlies'}{trans}{next} = 'r4q1findtruth'; - $self->{states}{'r4q1findtruth'}{sub} = sub { $self->r4q1findtruth(@_) }; - $self->{states}{'r4q1findtruth'}{trans}{wait} = 'r4q1findtruth'; - $self->{states}{'r4q1findtruth'}{trans}{next} = 'r4q1showlies'; - $self->{states}{'r4q1showlies'}{sub} = sub { $self->r4q1showlies(@_) }; - $self->{states}{'r4q1showlies'}{trans}{wait} = 'r4q1showlies'; - $self->{states}{'r4q1showlies'}{trans}{next} = 'r4q1showtruth'; - $self->{states}{'r4q1showtruth'}{sub} = sub { $self->r4q1showtruth(@_) }; - $self->{states}{'r4q1showtruth'}{trans}{wait} = 'r4q1showtruth'; - $self->{states}{'r4q1showtruth'}{trans}{next} = 'r4q1reveallies'; - $self->{states}{'r4q1reveallies'}{sub} = sub { $self->r4q1reveallies(@_) }; - $self->{states}{'r4q1reveallies'}{trans}{wait} = 'r4q1reveallies'; - $self->{states}{'r4q1reveallies'}{trans}{next} = 'r4q1showscore'; - $self->{states}{'r4q1showscore'}{sub} = sub { $self->r4q1showscore(@_) }; - $self->{states}{'r4q1showscore'}{trans}{wait} = 'r4q1showscore'; - $self->{states}{'r4q1showscore'}{trans}{next} = 'gameover'; - - - $self->{states}{'gameover'}{sub} = sub { $self->gameover(@_) }; - $self->{states}{'gameover'}{trans}{wait} = 'gameover'; - $self->{states}{'gameover'}{trans}{next} = 'getplayers'; + $self->{states}{'gameover'}{sub} = sub { $self->gameover(@_) }; + $self->{states}{'gameover'}{trans}{wait} = 'gameover'; + $self->{states}{'gameover'}{trans}{next} = 'getplayers'; } sub commify { - my $self = shift; - my $text = reverse $_[0]; - $text =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g; - return scalar reverse $text; + my $self = shift; + my $text = reverse $_[0]; + $text =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g; + return scalar reverse $text; } sub normalize_question { - my ($self, $text) = @_; + my ($self, $text) = @_; - my @words = split / /, $text; - my $uc = 0; - foreach my $word (@words) { - if ($word =~ m/^[A-Z]/) { - $uc++; + my @words = split / /, $text; + my $uc = 0; + foreach my $word (@words) { + if ($word =~ m/^[A-Z]/) { $uc++; } } - } - if ($uc >= @words * .8) { - $text = ucfirst lc $text; - } + if ($uc >= @words * .8) { $text = ucfirst lc $text; } - return $text; + return $text; } sub normalize_text { - my ($self, $text) = @_; + my ($self, $text) = @_; - $text = unidecode $text; + $text = unidecode $text; - $text =~ s/^\s+|\s+$//g; - $text =~ s/\s+/ /g; - $text =~ s/^(the|a|an) //i; - $text =~ s/&/ AND /g; + $text =~ s/^\s+|\s+$//g; + $text =~ s/\s+/ /g; + $text =~ s/^(the|a|an) //i; + $text =~ s/&/ AND /g; - $text = lc substr($text, 0, 80); + $text = lc substr($text, 0, 80); - $text =~ s/\$\s+(\d)/\$$1/g; - $text =~ s/\s*%$//; - $text =~ s/(\d),(\d\d\d)/$1$2/g; - $text =~ s/(\D,)(\D)/$1 $2/g; + $text =~ s/\$\s+(\d)/\$$1/g; + $text =~ s/\s*%$//; + $text =~ s/(\d),(\d\d\d)/$1$2/g; + $text =~ s/(\D,)(\D)/$1 $2/g; - my @words = split / /, $text; - my @result; + my @words = split / /, $text; + my @result; - foreach my $word (@words) { - my $punct = $1 if $word =~ s/(\p{PosixPunct}+)$//; - my $newword = $word; + foreach my $word (@words) { + my $punct = $1 if $word =~ s/(\p{PosixPunct}+)$//; + my $newword = $word; - if ($word =~ m/^\d{4}$/ and $word >= 1700 and $word <= 2100) { - $newword = year2en($word); - } elsif ($word =~ m/^-?\d+$/) { - $newword = num2en($word); + if ($word =~ m/^\d{4}$/ and $word >= 1700 and $word <= 2100) { $newword = year2en($word); } + elsif ($word =~ m/^-?\d+$/) { + $newword = num2en($word); - if (defined $punct and $punct eq '%') { - $newword .= " percent"; - $punct = undef; - } - } elsif ($word =~ m/^(-?\d+)(?:st|nd|rd|th)$/i) { - $newword = num2en_ordinal($1); - } elsif ($word =~ m/^(-)?\$(\d+)?(\.\d+)?$/i) { - my ($neg, $dollars, $cents) = ($1, $2, $3); - $newword = ''; - $dollars = "$neg$dollars" if defined $neg and defined $dollars; + if (defined $punct and $punct eq '%') { + $newword .= " percent"; + $punct = undef; + } + } elsif ($word =~ m/^(-?\d+)(?:st|nd|rd|th)$/i) { + $newword = num2en_ordinal($1); + } elsif ($word =~ m/^(-)?\$(\d+)?(\.\d+)?$/i) { + my ($neg, $dollars, $cents) = ($1, $2, $3); + $newword = ''; + $dollars = "$neg$dollars" if defined $neg and defined $dollars; - if (defined $dollars) { - $word = num2en($dollars); - $newword = "$word " . (abs $dollars == 1 ? "dollar" : "dollars"); - } + if (defined $dollars) { + $word = num2en($dollars); + $newword = "$word " . (abs $dollars == 1 ? "dollar" : "dollars"); + } - if (defined $cents) { - $cents =~ s/^\.0*//; - $cents = "$neg$cents" if defined $neg and not defined $dollars; - $word = num2en($cents); - $newword .= " and " if defined $dollars; - $newword .= (abs $cents == 1 ? "$word cent" : "$word cents"); - } - } elsif ($word =~ m/^(-?\d*\.\d+)(?:st|nd|rd|th)?$/i) { - $newword = num2en($1); - } elsif ($word =~ m{^(-?\d+\s*/\s*-?\d+)(?:st|nd|rd|th)?$}i) { - $newword = fraction2words($1); + if (defined $cents) { + $cents =~ s/^\.0*//; + $cents = "$neg$cents" if defined $neg and not defined $dollars; + $word = num2en($cents); + $newword .= " and " if defined $dollars; + $newword .= (abs $cents == 1 ? "$word cent" : "$word cents"); + } + } elsif ($word =~ m/^(-?\d*\.\d+)(?:st|nd|rd|th)?$/i) { + $newword = num2en($1); + } elsif ($word =~ m{^(-?\d+\s*/\s*-?\d+)(?:st|nd|rd|th)?$}i) { + $newword = fraction2words($1); + } + + $newword .= $punct if defined $punct; + push @result, $newword; } - $newword .= $punct if defined $punct; - push @result, $newword; - } + $text = uc b2a("@result", s => 1); - $text = uc b2a ("@result", s => 1); + $text =~ s/([A-Z])\./$1/g; + $text =~ s/-/ /g; + $text =~ s/["'?!]//g; + $text =~ s/\s+/ /g; + $text =~ s/^\s+|\s+$//g; - $text =~ s/([A-Z])\./$1/g; - $text =~ s/-/ /g; - $text =~ s/["'?!]//g; - $text =~ s/\s+/ /g; - $text =~ s/^\s+|\s+$//g; - - return substr $text, 0, 80; + return substr $text, 0, 80; } sub validate_lie { - my ($self, $truth, $lie) = @_; - my %truth_words = @{stem map { $_ => 1 } grep { /^\w+$/ and not exists $self->{stopwords}{lc $_} } split /\b/, $truth}; - my $truth_word_count = keys %truth_words; + my ($self, $truth, $lie) = @_; - my %lie_words = @{stem map { $_ => 1 } grep { /^\w+$/ and not exists $self->{stopwords}{lc $_} } split /\b/, $lie}; - my $lie_word_count = keys %lie_words; + my %truth_words = @{stem map { $_ => 1 } grep { /^\w+$/ and not exists $self->{stopwords}{lc $_} } split /\b/, $truth}; + my $truth_word_count = keys %truth_words; - my $count = 0; - foreach my $word (keys %lie_words) { - if (exists $truth_words{$word}) { - $count++; + my %lie_words = @{stem map { $_ => 1 } grep { /^\w+$/ and not exists $self->{stopwords}{lc $_} } split /\b/, $lie}; + my $lie_word_count = keys %lie_words; + + my $count = 0; + + foreach my $word (keys %lie_words) { + if (exists $truth_words{$word}) { $count++; } } - } - if ($count == $truth_word_count) { - return 0; - } + if ($count == $truth_word_count) { return 0; } - my $stripped_truth = $truth; - $stripped_truth =~ s/(?:\s|\p{PosixPunct})+//g; - my $stripped_lie = $lie; - $stripped_lie =~ s/(?:\s|\p{PosixPunct})+//g; + my $stripped_truth = $truth; + $stripped_truth =~ s/(?:\s|\p{PosixPunct})+//g; + my $stripped_lie = $lie; + $stripped_lie =~ s/(?:\s|\p{PosixPunct})+//g; - if ($stripped_truth eq $stripped_lie) { - return 0; - } + if ($stripped_truth eq $stripped_lie) { return 0; } - return 1; + return 1; } # generic state subroutines sub choosecategory { - my ($self, $state) = @_; + my ($self, $state) = @_; - if ($state->{init} or $state->{reroll_category}) { - delete $state->{current_category}; - $state->{current_player}++ unless $state->{reroll_category}; + if ($state->{init} or $state->{reroll_category}) { + delete $state->{current_category}; + $state->{current_player}++ unless $state->{reroll_category}; - if ($state->{current_player} >= @{$state->{players}}) { - $state->{current_player} = 0; + if ($state->{current_player} >= @{$state->{players}}) { $state->{current_player} = 0; } + + my @choices; + my @categories; + + if ($self->{metadata}->exists('filter', 'category_include_filter') and length $self->{metadata}->get_data('filter', 'category_include_filter')) { + my $filter = $self->{metadata}->get_data('filter', 'category_include_filter'); + @categories = grep { /$filter/i } keys %{$self->{categories}}; + } else { + @categories = keys %{$self->{categories}}; + } + + if ($self->{metadata}->exists('filter', 'category_exclude_filter') and length $self->{metadata}->get_data('filter', 'category_exclude_filter')) { + my $filter = $self->{metadata}->get_data('filter', 'category_exclude_filter'); + @categories = grep { $_ !~ /$filter/i } @categories; + } + + my $no_infinite_loops = 0; + while (1) { + last if ++$no_infinite_loops > 10000; + my $cat = $categories[rand @categories]; + + my @questions = keys %{$self->{categories}{$cat}}; + + if (not @questions) { + $self->{pbot}->{logger}->log("No questions for category $cat\n"); + next; + } + + if ($self->{metadata}->exists('settings', 'min_difficulty')) { + @questions = grep { $self->{categories}{$cat}{$_}->{value} >= $self->{metadata}->get_data('settings', 'min_difficulty') } @questions; + } + + if ($self->{metadata}->exists('settings', 'max_difficulty')) { + @questions = grep { $self->{categories}{$cat}{$_}->{value} <= $self->{metadata}->get_data('settings', 'max_difficulty') } @questions; + } + + if ($self->{metadata}->exists('settings', 'seen_expiry')) { + my $now = time; + @questions = grep { $now - $self->{categories}{$cat}{$_}->{seen_timestamp} >= $self->{metadata}->get_data('settings', 'seen_expiry') } @questions; + } + + next if not @questions; + + if (not grep { $_ eq $cat } @choices) { + push @choices, $cat; + } + + last if @choices == $self->{metadata}->get_data('settings', 'category_choices') or @categories < $self->{metadata}->get_data('settings', 'category_choices'); + } + + if (not @choices) { + $self->{pbot}->{logger}->log("Out of questions with current settings!\n"); + + # XXX: do something useful here + } + + push @choices, 'RANDOM CATEGORY'; + push @choices, 'REROLL CATEGORIES'; + + $state->{categories_text} = ''; + my $i = 1; + my $comma = ''; + foreach my $choice (@choices) { + $state->{categories_text} .= "$comma$color{green}$i)$color{reset} " . $choice; + $i++; + $comma = "; "; + } + + if ($state->{reroll_category} and not $self->{metadata}->get_data('settings', 'category_autopick')) { + $self->send_message($self->{channel}, "$state->{categories_text}"); + } + + $state->{category_options} = \@choices; + $state->{category_rerolls} = 0 if $state->{init}; + delete $state->{init}; + delete $state->{reroll_category}; } - my @choices; - my @categories; + if (exists $state->{current_category} or not @{$state->{players}}) { return 'next'; } - if ($self->{metadata}->exists('filter', 'category_include_filter') and length $self->{metadata}->get_data('filter', 'category_include_filter')) { - my $filter = $self->{metadata}->get_data('filter', 'category_include_filter'); - @categories = grep { /$filter/i } keys %{$self->{categories}}; - } else { - @categories = keys %{$self->{categories}}; + my $tock; + if ($state->{first_tock}) { $tock = 3; } + else { $tock = $self->{tock_duration}; } + + if ($state->{ticks} % $tock == 0) { + $state->{tocked} = 1; + + if (exists $state->{random_category} or $self->{metadata}->get_data('settings', 'category_autopick')) { + delete $state->{random_category}; + my $category = $state->{category_options}->[rand(@{$state->{category_options}} - 2)]; + my $questions = scalar keys %{$self->{categories}{$category}}; + $self->send_message($self->{channel}, "$color{green}Category:$color{reset} $category! ($questions questions)"); + $state->{current_category} = $category; + return 'next'; + } + + if (++$state->{counter} > $state->{max_count}) { + + # $state->{players}->[$state->{current_player}]->{missedinputs}++; + my $name = $state->{players}->[$state->{current_player}]->{name}; + my $category = $state->{category_options}->[rand(@{$state->{category_options}} - 2)]; + $self->send_message($self->{channel}, "$name took too long to choose. Randomly choosing: $category!"); + $state->{current_category} = $category; + return 'next'; + } + + my $name = $state->{players}->[$state->{current_player}]->{name}; + my $warning; + if ($state->{counter} == $state->{max_count}) { $warning = $color{red}; } + elsif ($state->{counter} == $state->{max_count} - 1) { $warning = $color{yellow}; } + else { $warning = ''; } + + my $remaining = $self->{tock_duration} * $state->{max_count}; + $remaining -= $self->{tock_duration} * ($state->{counter} - 1); + $remaining = "(" . (concise duration $remaining) . " remaining)"; + + $self->send_message($self->{channel}, "$name: $warning$remaining Choose a category via `/msg me c `:$color{reset}"); + $self->send_message($self->{channel}, "$state->{categories_text}"); + return 'wait'; } - if ($self->{metadata}->exists('filter', 'category_exclude_filter') and length $self->{metadata}->get_data('filter', 'category_exclude_filter')) { - my $filter = $self->{metadata}->get_data('filter', 'category_exclude_filter'); - @categories = grep { $_ !~ /$filter/i } @categories; - } - - my $no_infinite_loops = 0; - while (1) { - last if ++$no_infinite_loops > 10000; - my $cat = $categories[rand @categories]; - - my @questions = keys %{$self->{categories}{$cat}}; - - if (not @questions) { - $self->{pbot}->{logger}->log("No questions for category $cat\n"); - next; - } - - if ($self->{metadata}->exists('settings', 'min_difficulty')) { - @questions = grep { $self->{categories}{$cat}{$_}->{value} >= $self->{metadata}->get_data('settings', 'min_difficulty') } @questions; - } - - if ($self->{metadata}->exists('settings', 'max_difficulty')) { - @questions = grep { $self->{categories}{$cat}{$_}->{value} <= $self->{metadata}->get_data('settings', 'max_difficulty') } @questions; - } - - if ($self->{metadata}->exists('settings', 'seen_expiry')) { - my $now = time; - @questions = grep { $now - $self->{categories}{$cat}{$_}->{seen_timestamp} >= $self->{metadata}->get_data('settings', 'seen_expiry') } @questions; - } - - next if not @questions; - - if (not grep { $_ eq $cat } @choices) { - push @choices, $cat; - } - - last if @choices == $self->{metadata}->get_data('settings', 'category_choices') or @categories < $self->{metadata}->get_data('settings', 'category_choices'); - } - - if (not @choices) { - $self->{pbot}->{logger}->log("Out of questions with current settings!\n"); - # XXX: do something useful here - } - - push @choices, 'RANDOM CATEGORY'; - push @choices, 'REROLL CATEGORIES'; - - $state->{categories_text} = ''; - my $i = 1; - my $comma = ''; - foreach my $choice (@choices) { - $state->{categories_text} .= "$comma$color{green}$i)$color{reset} " . $choice; - $i++; - $comma = "; "; - } - - if ($state->{reroll_category} and not $self->{metadata}->get_data('settings', 'category_autopick')) { - $self->send_message($self->{channel}, "$state->{categories_text}"); - } - - $state->{category_options} = \@choices; - $state->{category_rerolls} = 0 if $state->{init}; - delete $state->{init}; - delete $state->{reroll_category}; - } - - if (exists $state->{current_category} or not @{$state->{players}}) { - return 'next'; - } - - my $tock; - if ($state->{first_tock}) { - $tock = 3; - } else { - $tock = $self->{tock_duration}; - } - - if ($state->{ticks} % $tock == 0) { - $state->{tocked} = 1; - - if (exists $state->{random_category} or $self->{metadata}->get_data('settings', 'category_autopick')) { - delete $state->{random_category}; - my $category = $state->{category_options}->[rand (@{$state->{category_options}} - 2)]; - my $questions = scalar keys %{ $self->{categories}{$category} }; - $self->send_message($self->{channel}, "$color{green}Category:$color{reset} $category! ($questions questions)"); - $state->{current_category} = $category; - return 'next'; - } - - if (++$state->{counter} > $state->{max_count}) { - # $state->{players}->[$state->{current_player}]->{missedinputs}++; - my $name = $state->{players}->[$state->{current_player}]->{name}; - my $category = $state->{category_options}->[rand (@{$state->{category_options}} - 2)]; - $self->send_message($self->{channel}, "$name took too long to choose. Randomly choosing: $category!"); - $state->{current_category} = $category; - return 'next'; - } - - my $name = $state->{players}->[$state->{current_player}]->{name}; - my $warning; - if ($state->{counter} == $state->{max_count}) { - $warning = $color{red}; - } elsif ($state->{counter} == $state->{max_count} - 1) { - $warning = $color{yellow}; - } else { - $warning = ''; - } - - my $remaining = $self->{tock_duration} * $state->{max_count}; - $remaining -= $self->{tock_duration} * ($state->{counter} - 1); - $remaining = "(" . (concise duration $remaining) . " remaining)"; - - $self->send_message($self->{channel}, "$name: $warning$remaining Choose a category via `/msg me c `:$color{reset}"); - $self->send_message($self->{channel}, "$state->{categories_text}"); - return 'wait'; - } - - if (exists $state->{current_category}) { - return 'next'; - } else { - return 'wait'; - } + if (exists $state->{current_category}) { return 'next'; } + else { return 'wait'; } } sub getnewquestion { - my ($self, $state) = @_; + my ($self, $state) = @_; - if ($state->{ticks} % 3 == 0) { - my @questions = keys %{$self->{categories}{$state->{current_category}}}; + if ($state->{ticks} % 3 == 0) { + my @questions = keys %{$self->{categories}{$state->{current_category}}}; - if (exists $state->{seen_questions}->{$state->{current_category}}) { - my @seen = keys %{$state->{seen_questions}->{$state->{current_category}}}; - my %seen = map { $_ => 1 } @seen; - @questions = grep { !defined $seen{$_} } @questions; + if (exists $state->{seen_questions}->{$state->{current_category}}) { + my @seen = keys %{$state->{seen_questions}->{$state->{current_category}}}; + my %seen = map { $_ => 1 } @seen; + @questions = grep { !defined $seen{$_} } @questions; + } + + @questions = + sort { $self->{categories}{$state->{current_category}}{$a}->{seen_timestamp} <=> $self->{categories}{$state->{current_category}}{$b}->{seen_timestamp} } @questions; + my $now = time; + @questions = grep { $now - $self->{categories}{$state->{current_category}}{$_}->{seen_timestamp} >= $self->{metadata}->get_data('settings', 'seen_expiry') } @questions; + + if ($self->{metadata}->exists('settings', 'min_difficulty')) { + @questions = grep { $self->{categories}{$state->{current_category}}{$_}->{value} >= $self->{metadata}->get_data('settings', 'min_difficulty') } @questions; + } + + if ($self->{metadata}->exists('settings', 'max_difficulty')) { + @questions = grep { $self->{categories}{$state->{current_category}}{$_}->{value} <= $self->{metadata}->get_data('settings', 'max_difficulty') } @questions; + } + + if (not @questions) { + $self->send_message($self->{channel}, "No more questions available in category $state->{current_category}! Picking new category..."); + delete $state->{seen_questions}->{$state->{current_category}}; + @questions = keys %{$self->{categories}{$state->{current_category}}}; + $state->{reroll_category} = 1; + } + + if ($state->{reroll_question}) { + delete $state->{reroll_question}; + + unless ($state->{reroll_category}) { + my $count = @questions; + $self->send_message( + $self->{channel}, + "Rerolling new question from $state->{current_category} (" . $self->commify($count) . " question" . ($count == 1 ? '' : 's') . " remaining)\n" + ); + } + } + + $state->{current_question} = $self->{categories}{$state->{current_category}}{$questions[0]}; + $state->{current_question}->{question} = $self->normalize_question($state->{current_question}->{question}); + $state->{current_question}->{answer} = $self->normalize_text($state->{current_question}->{answer}); + + $state->{current_question}->{seen_timestamp} = time unless $state->{reroll_category}; + + my @alts = map { $self->normalize_text($_) } @{$state->{current_question}->{alternativeSpellings}}; + $state->{current_question}->{alternativeSpellings} = \@alts; + + $state->{seen_questions}->{$state->{current_category}}->{$state->{current_question}->{id}} = 1; + + foreach my $player (@{$state->{players}}) { + delete $player->{lie}; + delete $player->{lie_count}; + delete $player->{truth}; + delete $player->{good_lie}; + delete $player->{deceived}; + delete $player->{skip}; + delete $player->{reroll}; + delete $player->{keep}; + } + $state->{current_choices_text} = ""; + return 'next'; + } else { + return 'wait'; } - - @questions = sort { $self->{categories}{$state->{current_category}}{$a}->{seen_timestamp} <=> $self->{categories}{$state->{current_category}}{$b}->{seen_timestamp} } @questions; - my $now = time; - @questions = grep { $now - $self->{categories}{$state->{current_category}}{$_}->{seen_timestamp} >= $self->{metadata}->get_data('settings', 'seen_expiry') } @questions; - - if ($self->{metadata}->exists('settings', 'min_difficulty')) { - @questions = grep { $self->{categories}{$state->{current_category}}{$_}->{value} >= $self->{metadata}->get_data('settings', 'min_difficulty') } @questions; - } - - if ($self->{metadata}->exists('settings', 'max_difficulty')) { - @questions = grep { $self->{categories}{$state->{current_category}}{$_}->{value} <= $self->{metadata}->get_data('settings', 'max_difficulty') } @questions; - } - - if (not @questions) { - $self->send_message($self->{channel}, "No more questions available in category $state->{current_category}! Picking new category..."); - delete $state->{seen_questions}->{$state->{current_category}}; - @questions = keys %{$self->{categories}{$state->{current_category}}}; - $state->{reroll_category} = 1; - } - - if ($state->{reroll_question}) { - delete $state->{reroll_question}; - - unless ($state->{reroll_category}) { - my $count = @questions; - $self->send_message($self->{channel}, "Rerolling new question from $state->{current_category} (" . $self->commify($count) . " question" . ($count == 1 ? '' : 's') . " remaining)\n"); - } - } - - $state->{current_question} = $self->{categories}{$state->{current_category}}{$questions[0]}; - $state->{current_question}->{question} = $self->normalize_question($state->{current_question}->{question}); - $state->{current_question}->{answer} = $self->normalize_text($state->{current_question}->{answer}); - - $state->{current_question}->{seen_timestamp} = time unless $state->{reroll_category}; - - my @alts = map { $self->normalize_text($_) } @{$state->{current_question}->{alternativeSpellings}}; - $state->{current_question}->{alternativeSpellings} = \@alts; - - $state->{seen_questions}->{$state->{current_category}}->{$state->{current_question}->{id}} = 1; - - foreach my $player (@{$state->{players}}) { - delete $player->{lie}; - delete $player->{lie_count}; - delete $player->{truth}; - delete $player->{good_lie}; - delete $player->{deceived}; - delete $player->{skip}; - delete $player->{reroll}; - delete $player->{keep}; - } - $state->{current_choices_text} = ""; - return 'next'; - } else { - return 'wait'; - } } sub showquestion { - my ($self, $state, $show_category) = @_; + my ($self, $state, $show_category) = @_; - return if $state->{reroll_category}; + return if $state->{reroll_category}; - if (exists $state->{current_question}) { - my $category = ""; - my $value = ""; + if (exists $state->{current_question}) { + my $category = ""; + my $value = ""; - if ($show_category) { - $category = "[$state->{current_category}] "; + if ($show_category) { $category = "[$state->{current_category}] "; } + + if ($state->{current_question}->{value}) { $value = "[$state->{current_question}->{value}] "; } + + $self->send_message( + $self->{channel}, + "$color{green}Current question:$color{reset} " . $self->commify($state->{current_question}->{id}) . ") $category$value$state->{current_question}->{question}" + ); + } else { + $self->send_message($self->{channel}, "There is no current question."); } - - if ($state->{current_question}->{value}) { - $value = "[$state->{current_question}->{value}] "; - } - - $self->send_message($self->{channel}, "$color{green}Current question:$color{reset} " . $self->commify($state->{current_question}->{id}) . ") $category$value$state->{current_question}->{question}"); - } else { - $self->send_message($self->{channel}, "There is no current question."); - } } sub getlies { - my ($self, $state) = @_; + my ($self, $state) = @_; - return 'skip' if $state->{reroll_category}; + return 'skip' if $state->{reroll_category}; - my $tock; - if ($state->{first_tock}) { - $tock = 3; - } else { - $tock = $self->{tock_duration}; - } + my $tock; + if ($state->{first_tock}) { $tock = 3; } + else { $tock = $self->{tock_duration}; } - my @nolies; - my $reveallies = ". Revealing lies! "; - my $lies = 0; - my $comma = ''; - my @keeps; - my @rerolls; - my @skips; - foreach my $player (@{$state->{players}}) { - if (not exists $player->{lie}) { - push @nolies, $player->{name}; - } else { - $lies++; - $reveallies .= "$comma$player->{name}: $player->{lie}"; - $comma = '; '; - } + my @nolies; + my $reveallies = ". Revealing lies! "; + my $lies = 0; + my $comma = ''; + my @keeps; + my @rerolls; + my @skips; - if ($player->{reroll}) { - push @rerolls, $player->{name}; - } - - if ($player->{skip}) { - push @skips, $player->{name}; - } - - if ($player->{keep}) { - push @keeps, $player->{name}; - } - } - - return 'next' if not @nolies; - - $reveallies = "" if not $lies; - - if (@rerolls) { - my $needed = int (@{$state->{players}} / 2) + 1; - $needed += @keeps; - $needed -= @rerolls; - if ($needed <= 0) { - $state->{reroll_question} = 1; - $self->send_message($self->{channel}, "The answer was: " . uc ($state->{current_question}->{answer}) . $reveallies); - return 'reroll'; - } - } - - if (@skips) { - my $needed = int (@{$state->{players}} / 2) + 1; - $needed += @keeps; - $needed -= @skips; - if ($needed <= 0) { - $self->send_message($self->{channel}, "The answer was: " . uc ($state->{current_question}->{answer}) . $reveallies); - return 'skip'; - } - } - - if ($state->{ticks} % $tock == 0) { - $state->{tocked} = 1; - - if (++$state->{counter} > $state->{max_count}) { - my @missedinputs; - foreach my $player (@{$state->{players}}) { - if (not exists $player->{lie}) { - push @missedinputs, $player->{name}; - $player->{missedinputs}++; + foreach my $player (@{$state->{players}}) { + if (not exists $player->{lie}) { push @nolies, $player->{name}; } + else { + $lies++; + $reveallies .= "$comma$player->{name}: $player->{lie}"; + $comma = '; '; } - } - if (@missedinputs) { - my $missed = join ', ', @missedinputs; - $self->send_message($self->{channel}, "$missed failed to submit a lie in time!"); - } - return 'next'; + if ($player->{reroll}) { push @rerolls, $player->{name}; } + + if ($player->{skip}) { push @skips, $player->{name}; } + + if ($player->{keep}) { push @keeps, $player->{name}; } } - my $players = join ', ', @nolies; + return 'next' if not @nolies; - my $warning; - if ($state->{counter} == $state->{max_count}) { - $warning = $color{red}; - } elsif ($state->{counter} == $state->{max_count} - 1) { - $warning = $color{yellow}; - } else { - $warning = ''; + $reveallies = "" if not $lies; + + if (@rerolls) { + my $needed = int(@{$state->{players}} / 2) + 1; + $needed += @keeps; + $needed -= @rerolls; + if ($needed <= 0) { + $state->{reroll_question} = 1; + $self->send_message($self->{channel}, "The answer was: " . uc($state->{current_question}->{answer}) . $reveallies); + return 'reroll'; + } } - my $remaining = $self->{tock_duration} * $state->{max_count}; - $remaining -= $self->{tock_duration} * ($state->{counter} - 1); - $remaining = "(" . (concise duration $remaining) . " remaining)"; + if (@skips) { + my $needed = int(@{$state->{players}} / 2) + 1; + $needed += @keeps; + $needed -= @skips; + if ($needed <= 0) { + $self->send_message($self->{channel}, "The answer was: " . uc($state->{current_question}->{answer}) . $reveallies); + return 'skip'; + } + } - $self->send_message($self->{channel}, "$players: $warning$remaining Submit your lie now via `/msg me lie `!"); - } + if ($state->{ticks} % $tock == 0) { + $state->{tocked} = 1; - return 'wait'; + if (++$state->{counter} > $state->{max_count}) { + my @missedinputs; + foreach my $player (@{$state->{players}}) { + if (not exists $player->{lie}) { + push @missedinputs, $player->{name}; + $player->{missedinputs}++; + } + } + + if (@missedinputs) { + my $missed = join ', ', @missedinputs; + $self->send_message($self->{channel}, "$missed failed to submit a lie in time!"); + } + return 'next'; + } + + my $players = join ', ', @nolies; + + my $warning; + if ($state->{counter} == $state->{max_count}) { $warning = $color{red}; } + elsif ($state->{counter} == $state->{max_count} - 1) { $warning = $color{yellow}; } + else { $warning = ''; } + + my $remaining = $self->{tock_duration} * $state->{max_count}; + $remaining -= $self->{tock_duration} * ($state->{counter} - 1); + $remaining = "(" . (concise duration $remaining) . " remaining)"; + + $self->send_message($self->{channel}, "$players: $warning$remaining Submit your lie now via `/msg me lie `!"); + } + + return 'wait'; } sub findtruth { - my ($self, $state) = @_; + my ($self, $state) = @_; - my $tock; - if ($state->{first_tock}) { - $tock = 3; - } else { - $tock = $self->{tock_duration}; - } - - my @notruth; - foreach my $player (@{$state->{players}}) { - if (not exists $player->{truth}) { - push @notruth, $player->{name}; - } - } - - return 'next' if not @notruth; - - if ($state->{init}) { - delete $state->{init}; - - my @choices; - my @suggestions = @{$state->{current_question}->{suggestions}}; - my @lies; + my $tock; + if ($state->{first_tock}) { $tock = 3; } + else { $tock = $self->{tock_duration}; } + my @notruth; foreach my $player (@{$state->{players}}) { - if ($player->{lie}) { - if (not grep { $_ eq $player->{lie} } @lies) { - push @lies, uc $player->{lie}; + if (not exists $player->{truth}) { push @notruth, $player->{name}; } + } + + return 'next' if not @notruth; + + if ($state->{init}) { + delete $state->{init}; + + my @choices; + my @suggestions = @{$state->{current_question}->{suggestions}}; + my @lies; + + foreach my $player (@{$state->{players}}) { + if ($player->{lie}) { + if (not grep { $_ eq $player->{lie} } @lies) { + push @lies, uc $player->{lie}; + } + } } - } - } - while (1) { - my $limit = @{$state->{players}} < 5 ? 5 : @{$state->{players}}; - last if @choices >= $limit; + while (1) { + my $limit = @{$state->{players}} < 5 ? 5 : @{$state->{players}}; + last if @choices >= $limit; - if (@lies) { - my $random = rand @lies; - push @choices, $lies[$random]; - splice @lies, $random, 1; - next; - } + if (@lies) { + my $random = rand @lies; + push @choices, $lies[$random]; + splice @lies, $random, 1; + next; + } - if (@suggestions) { - my $random = rand @suggestions; - my $suggestion = uc $suggestions[$random]; - push @choices, $suggestion if not grep { $_ eq $suggestion } @choices; - splice @suggestions, $random, 1; - next; - } + if (@suggestions) { + my $random = rand @suggestions; + my $suggestion = uc $suggestions[$random]; + push @choices, $suggestion if not grep { $_ eq $suggestion } @choices; + splice @suggestions, $random, 1; + next; + } - last; - } - - splice @choices, rand @choices, 0, uc $state->{current_question}->{answer}; - $state->{correct_answer} = uc $state->{current_question}->{answer}; - - my $i = 0; - my $comma = ''; - my $text = ''; - foreach my $choice (@choices) { - ++$i; - $text .= "$comma$color{green}$i) $color{reset}$choice"; - $comma = '; '; - } - - $state->{current_choices_text} = $text; - $state->{current_choices} = \@choices; - } - - if ($state->{ticks} % $tock == 0) { - $state->{tocked} = 1; - if (++$state->{counter} > $state->{max_count}) { - my @missedinputs; - foreach my $player (@{$state->{players}}) { - if (not exists $player->{truth}) { - push @missedinputs, $player->{name}; - $player->{missedinputs}++; - $player->{score} -= $state->{lie_points}; + last; } - } - if (@missedinputs) { - my $missed = join ', ', @missedinputs; - $self->send_message($self->{channel}, "$missed failed to find the truth in time! They lose $state->{lie_points} points!"); - } - return 'next'; + splice @choices, rand @choices, 0, uc $state->{current_question}->{answer}; + $state->{correct_answer} = uc $state->{current_question}->{answer}; + + my $i = 0; + my $comma = ''; + my $text = ''; + foreach my $choice (@choices) { + ++$i; + $text .= "$comma$color{green}$i) $color{reset}$choice"; + $comma = '; '; + } + + $state->{current_choices_text} = $text; + $state->{current_choices} = \@choices; } - my $players = join ', ', @notruth; + if ($state->{ticks} % $tock == 0) { + $state->{tocked} = 1; + if (++$state->{counter} > $state->{max_count}) { + my @missedinputs; + foreach my $player (@{$state->{players}}) { + if (not exists $player->{truth}) { + push @missedinputs, $player->{name}; + $player->{missedinputs}++; + $player->{score} -= $state->{lie_points}; + } + } - my $warning; - if ($state->{counter} == $state->{max_count}) { - $warning = $color{red}; - } elsif ($state->{counter} == $state->{max_count} - 1) { - $warning = $color{yellow}; - } else { - $warning = ''; + if (@missedinputs) { + my $missed = join ', ', @missedinputs; + $self->send_message($self->{channel}, "$missed failed to find the truth in time! They lose $state->{lie_points} points!"); + } + return 'next'; + } + + my $players = join ', ', @notruth; + + my $warning; + if ($state->{counter} == $state->{max_count}) { $warning = $color{red}; } + elsif ($state->{counter} == $state->{max_count} - 1) { $warning = $color{yellow}; } + else { $warning = ''; } + + my $remaining = $self->{tock_duration} * $state->{max_count}; + $remaining -= $self->{tock_duration} * ($state->{counter} - 1); + $remaining = "(" . (concise duration $remaining) . " remaining)"; + + $self->send_message($self->{channel}, "$players: $warning$remaining Find the truth now via `/msg me c `!$color{reset}"); + $self->send_message($self->{channel}, "$state->{current_choices_text}"); } - my $remaining = $self->{tock_duration} * $state->{max_count}; - $remaining -= $self->{tock_duration} * ($state->{counter} - 1); - $remaining = "(" . (concise duration $remaining) . " remaining)"; - - $self->send_message($self->{channel}, "$players: $warning$remaining Find the truth now via `/msg me c `!$color{reset}"); - $self->send_message($self->{channel}, "$state->{current_choices_text}"); - } - - return 'wait'; + return 'wait'; } sub showlies { - my ($self, $state) = @_; + my ($self, $state) = @_; - my @liars; - my $player; + my @liars; + my $player; - my $tock; - if ($state->{first_tock}) { - $tock = 3; - } else { - $tock = 3; - } + my $tock; + if ($state->{first_tock}) { $tock = 3; } + else { $tock = 3; } - if ($state->{ticks} % $tock == 0) { - $state->{tocked} = 1; - while ($state->{current_lie_player} < @{$state->{players}}) { - $player = $state->{players}->[$state->{current_lie_player}]; - $state->{current_lie_player}++; - next if not exists $player->{truth}; + if ($state->{ticks} % $tock == 0) { + $state->{tocked} = 1; + while ($state->{current_lie_player} < @{$state->{players}}) { + $player = $state->{players}->[$state->{current_lie_player}]; + $state->{current_lie_player}++; + next if not exists $player->{truth}; - foreach my $liar (@{$state->{players}}) { - next if $liar->{id} == $player->{id}; - next if not exists $liar->{lie}; + foreach my $liar (@{$state->{players}}) { + next if $liar->{id} == $player->{id}; + next if not exists $liar->{lie}; - if ($liar->{lie} eq $player->{truth}) { - push @liars, $liar; - } - } + if ($liar->{lie} eq $player->{truth}) { push @liars, $liar; } + } - last if @liars; + last if @liars; - if ($player->{truth} ne $state->{correct_answer}) { - if ($self->{metadata}->get_data('settings', 'stats')) { - my $player_id = $self->{stats}->get_player_id($player->{name}, $self->{channel}); - my $player_data = $self->{stats}->get_player_data($player_id); - $player_data->{bad_guesses}++; - $self->{stats}->update_player_data($player_id, $player_data); + if ($player->{truth} ne $state->{correct_answer}) { + if ($self->{metadata}->get_data('settings', 'stats')) { + my $player_id = $self->{stats}->get_player_id($player->{name}, $self->{channel}); + my $player_data = $self->{stats}->get_player_data($player_id); + $player_data->{bad_guesses}++; + $self->{stats}->update_player_data($player_id, $player_data); + } + + my $points = $state->{lie_points} * 0.25; + $player->{score} -= $points; + $self->send_message($self->{channel}, "$player->{name} fell for my lie: \"$player->{truth}\". -$points points!"); + $player->{deceived} = $player->{truth}; + if ($state->{current_lie_player} < @{$state->{players}}) { return 'wait'; } + else { return 'next'; } + } } - my $points = $state->{lie_points} * 0.25; - $player->{score} -= $points; - $self->send_message($self->{channel}, "$player->{name} fell for my lie: \"$player->{truth}\". -$points points!"); - $player->{deceived} = $player->{truth}; - if ($state->{current_lie_player} < @{$state->{players}}) { - return 'wait'; + if (@liars) { + + my $liars_text = ''; + my $liars_no_apostrophe = ''; + my $lie = $player->{truth}; + my $gains = @liars == 1 ? 'gains' : 'gain'; + my $comma = ''; + + foreach my $liar (@liars) { + if ($self->{metadata}->get_data('settings', 'stats')) { + my $player_id = $self->{stats}->get_player_id($liar->{name}, $self->{channel}); + my $player_data = $self->{stats}->get_player_data($player_id); + $player_data->{players_deceived}++; + $self->{stats}->update_player_data($player_id, $player_data); + } + + $liars_text .= "$comma$liar->{name}'s"; + $liars_no_apostrophe .= "$comma$liar->{name}"; + $comma = ', '; + $liar->{score} += $state->{lie_points}; + $liar->{good_lie} = 1; + } + + if ($self->{metadata}->get_data('settings', 'stats')) { + my $player_id = $self->{stats}->get_player_id($player->{name}, $self->{channel}); + my $player_data = $self->{stats}->get_player_data($player_id); + $player_data->{bad_guesses}++; + $self->{stats}->update_player_data($player_id, $player_data); + } + + $self->send_message($self->{channel}, "$player->{name} fell for $liars_text lie: \"$lie\". $liars_no_apostrophe $gains +$state->{lie_points} points!"); + $player->{deceived} = $lie; + } + + if ($state->{current_lie_player} >= @{$state->{players}}) { + if (@liars) { delete $state->{tick_drift}; } + else { $state->{tick_drift} = $tock - 1; } + return 'next'; } else { - return 'next'; + return 'wait'; } - } } - if (@liars) { - my $liars_text = ''; - my $liars_no_apostrophe = ''; - my $lie = $player->{truth}; - my $gains = @liars == 1 ? 'gains' : 'gain'; - my $comma = ''; - - foreach my $liar (@liars) { - if ($self->{metadata}->get_data('settings', 'stats')) { - my $player_id = $self->{stats}->get_player_id($liar->{name}, $self->{channel}); - my $player_data = $self->{stats}->get_player_data($player_id); - $player_data->{players_deceived}++; - $self->{stats}->update_player_data($player_id, $player_data); - } - - $liars_text .= "$comma$liar->{name}'s"; - $liars_no_apostrophe .= "$comma$liar->{name}"; - $comma = ', '; - $liar->{score} += $state->{lie_points}; - $liar->{good_lie} = 1; - } - - if ($self->{metadata}->get_data('settings', 'stats')) { - my $player_id = $self->{stats}->get_player_id($player->{name}, $self->{channel}); - my $player_data = $self->{stats}->get_player_data($player_id); - $player_data->{bad_guesses}++; - $self->{stats}->update_player_data($player_id, $player_data); - } - - $self->send_message($self->{channel}, "$player->{name} fell for $liars_text lie: \"$lie\". $liars_no_apostrophe $gains +$state->{lie_points} points!"); - $player->{deceived} = $lie; - } - - if ($state->{current_lie_player} >= @{$state->{players}}) { - if (@liars) { - delete $state->{tick_drift}; - } else { - $state->{tick_drift} = $tock - 1; - } - return 'next'; - } else { - return 'wait'; - } - } - - return 'wait'; + return 'wait'; } sub showtruth { - my ($self, $state) = @_; + my ($self, $state) = @_; - if ($state->{ticks} % 3 == 0) { - my $player_id; - my $player_data; - my $players; - my $comma = ''; - my $count = 0; - foreach my $player (@{$state->{players}}) { - if ($self->{metadata}->get_data('settings', 'stats')) { - $player_id = $self->{stats}->get_player_id($player->{name}, $self->{channel}); - $player_data = $self->{stats}->get_player_data($player_id); + if ($state->{ticks} % 3 == 0) { - $player_data->{questions_played}++; - $player_data->{nick} = $player->{name}; # update nick in stats database once per question (nick changes, etc) - } + my $player_id; + my $player_data; + my $players; + my $comma = ''; + my $count = 0; - if (exists $player->{deceived}) { - if ($self->{metadata}->get_data('settings', 'stats')) { - $self->{stats}->update_player_data($player_id, $player_data); + foreach my $player (@{$state->{players}}) { + if ($self->{metadata}->get_data('settings', 'stats')) { + $player_id = $self->{stats}->get_player_id($player->{name}, $self->{channel}); + $player_data = $self->{stats}->get_player_data($player_id); + + $player_data->{questions_played}++; + $player_data->{nick} = $player->{name}; # update nick in stats database once per question (nick changes, etc) + } + + if (exists $player->{deceived}) { + if ($self->{metadata}->get_data('settings', 'stats')) { $self->{stats}->update_player_data($player_id, $player_data); } + next; + } + + if (exists $player->{truth} and $player->{truth} eq $state->{correct_answer}) { + if ($self->{metadata}->get_data('settings', 'stats')) { + $player_data->{good_guesses}++; + $self->{stats}->update_player_data($player_id, $player_data); + } + $count++; + $players .= "$comma$player->{name}"; + $comma = ', '; + $player->{score} += $state->{truth_points}; + } } - next; - } - if (exists $player->{truth} and $player->{truth} eq $state->{correct_answer}) { - if ($self->{metadata}->get_data('settings', 'stats')) { - $player_data->{good_guesses}++; - $self->{stats}->update_player_data($player_id, $player_data); - } - $count++; - $players .= "$comma$player->{name}"; - $comma = ', '; - $player->{score} += $state->{truth_points}; - } - } + if ($count) { $self->send_message($self->{channel}, "$players got the correct answer: \"$state->{correct_answer}\". +$state->{truth_points} points!"); } + else { $self->send_message($self->{channel}, "Nobody found the truth! The answer was: $state->{correct_answer}"); } - if ($count) { - $self->send_message($self->{channel}, "$players got the correct answer: \"$state->{correct_answer}\". +$state->{truth_points} points!"); + $self->add_new_suggestions($state); + + return 'next'; } else { - $self->send_message($self->{channel}, "Nobody found the truth! The answer was: $state->{correct_answer}"); + return 'wait'; } - - $self->add_new_suggestions($state); - - return 'next'; - } else { - return 'wait'; - } } sub reveallies { - my ($self, $state) = @_; + my ($self, $state) = @_; - if ($state->{ticks} % 3 == 0) { - my $text = 'Revealing lies! '; - my $comma = ''; - foreach my $player (@{$state->{players}}) { - next if not exists $player->{lie}; - $text .= "$comma$player->{name}: $player->{lie}"; - $comma = '; '; + if ($state->{ticks} % 3 == 0) { + my $text = 'Revealing lies! '; + my $comma = ''; + foreach my $player (@{$state->{players}}) { + next if not exists $player->{lie}; + $text .= "$comma$player->{name}: $player->{lie}"; + $comma = '; '; - if ($player->{good_lie}) { - if ($self->{metadata}->get_data('settings', 'stats')) { - my $player_id = $self->{stats}->get_player_id($player->{name}, $self->{channel}); - my $player_data = $self->{stats}->get_player_data($player_id); - $player_data->{good_lies}++; - $self->{stats}->update_player_data($player_id, $player_data); + if ($player->{good_lie}) { + if ($self->{metadata}->get_data('settings', 'stats')) { + my $player_id = $self->{stats}->get_player_id($player->{name}, $self->{channel}); + my $player_data = $self->{stats}->get_player_data($player_id); + $player_data->{good_lies}++; + $self->{stats}->update_player_data($player_id, $player_data); + } + } } - } + + $self->send_message($self->{channel}, "$text"); + + return 'next'; + } else { + return 'wait'; } - - $self->send_message($self->{channel}, "$text"); - - return 'next'; - } else { - return 'wait'; - } } sub showscore { - my ($self, $state) = @_; + my ($self, $state) = @_; - if ($state->{ticks} % 3 == 0) { - my $text = ''; - my $comma = ''; - foreach my $player (sort { $b->{score} <=> $a->{score} } @{$state->{players}}) { - $text .= "$comma$player->{name}: " . $self->commify($player->{score}); - $comma = '; '; + if ($state->{ticks} % 3 == 0) { + my $text = ''; + my $comma = ''; + foreach my $player (sort { $b->{score} <=> $a->{score} } @{$state->{players}}) { + $text .= "$comma$player->{name}: " . $self->commify($player->{score}); + $comma = '; '; + } + + $text = "none" if not length $text; + + $self->send_message($self->{channel}, "$color{green}Scores:$color{reset} $text"); + return 'next'; + } else { + return 'wait'; } - - $text = "none" if not length $text; - - $self->send_message($self->{channel}, "$color{green}Scores:$color{reset} $text"); - return 'next'; - } else { - return 'wait'; - } } sub showfinalscore { - my ($self, $state) = @_; + my ($self, $state) = @_; - if ($state->{newstate}) { - my $player_id; - my $player_data; - my $mentions = ""; - my $text = ""; - my $comma = ""; - my $i = @{$state->{players}}; - $state->{finalscores} = []; - foreach my $player (sort { $a->{score} <=> $b->{score} } @{$state->{players}}) { - if ($self->{metadata}->get_data('settings', 'stats')) { - $player_id = $self->{stats}->get_player_id($player->{name}, $self->{channel}); - $player_data = $self->{stats}->get_player_data($player_id); + if ($state->{newstate}) { - $player_data->{games_played}++; - $player_data->{avg_score} *= $player_data->{games_played} - 1; - $player_data->{avg_score} += $player->{score}; - $player_data->{avg_score} /= $player_data->{games_played}; - $player_data->{low_score} = $player->{score} if $player_data->{low_score} == 0; + my $player_id; - if ($player->{score} > $player_data->{high_score}) { - $player_data->{high_score} = $player->{score}; - } elsif ($player->{score} < $player_data->{low_score}) { - $player_data->{low_score} = $player->{score}; + my $player_data; + my $mentions = ""; + my $text = ""; + my $comma = ""; + my $i = @{$state->{players}}; + + $state->{finalscores} = []; + foreach my $player (sort { $a->{score} <=> $b->{score} } @{$state->{players}}) { + if ($self->{metadata}->get_data('settings', 'stats')) { + $player_id = $self->{stats}->get_player_id($player->{name}, $self->{channel}); + $player_data = $self->{stats}->get_player_data($player_id); + + $player_data->{games_played}++; + $player_data->{avg_score} *= $player_data->{games_played} - 1; + $player_data->{avg_score} += $player->{score}; + $player_data->{avg_score} /= $player_data->{games_played}; + $player_data->{low_score} = $player->{score} if $player_data->{low_score} == 0; + + if ($player->{score} > $player_data->{high_score}) { $player_data->{high_score} = $player->{score}; } + elsif ($player->{score} < $player_data->{low_score}) { $player_data->{low_score} = $player->{score}; } + } + + if ($i >= 4) { + $mentions = "$player->{name}: " . $self->commify($player->{score}) . "$comma$mentions"; + $comma = "; "; + if ($i == 4) { $mentions = "Honorable mentions: $mentions"; } + + if ($self->{metadata}->get_data('settings', 'stats')) { $self->{stats}->update_player_data($player_id, $player_data); } + + $i--; + next; + } elsif ($i == 3) { + $player_data->{times_third}++; + $text = sprintf("%15s%-13s%7s", "Third place: ", $player->{name}, $self->commify($player->{score})); + } elsif ($i == 2) { + $player_data->{times_second}++; + $text = sprintf("%15s%-13s%7s", "Second place: ", $player->{name}, $self->commify($player->{score})); + } elsif ($i == 1) { + $player_data->{times_first}++; + $text = sprintf("%15s%-13s%7s", "WINNER: ", $player->{name}, $self->commify($player->{score})); + } + + if ($self->{metadata}->get_data('settings', 'stats')) { $self->{stats}->update_player_data($player_id, $player_data); } + + push @{$state->{finalscores}}, $text; + $i--; } - } - - if ($i >= 4) { - $mentions = "$player->{name}: " . $self->commify($player->{score}) . "$comma$mentions"; - $comma = "; "; - if ($i == 4) { - $mentions = "Honorable mentions: $mentions"; - } - - if ($self->{metadata}->get_data('settings', 'stats')) { - $self->{stats}->update_player_data($player_id, $player_data); - } - - $i--; - next; - } elsif ($i == 3) { - $player_data->{times_third}++; - $text = sprintf("%15s%-13s%7s", "Third place: ", $player->{name}, $self->commify($player->{score})); - } elsif ($i == 2) { - $player_data->{times_second}++; - $text = sprintf("%15s%-13s%7s", "Second place: ", $player->{name}, $self->commify($player->{score})); - } elsif ($i == 1) { - $player_data->{times_first}++; - $text = sprintf("%15s%-13s%7s", "WINNER: ", $player->{name}, $self->commify($player->{score})); - } - - if ($self->{metadata}->get_data('settings', 'stats')) { - $self->{stats}->update_player_data($player_id, $player_data); - } - - push @{$state->{finalscores}}, $text; - $i--; - } - push @{$state->{finalscores}}, $mentions if length $mentions; - } - - my $tock; - if ($state->{first_tock}) { - $tock = 2; - } else { - $tock = 3; - } - - if ($state->{ticks} % $tock == 0) { - $state->{tocked} = 1; - - if (not @{$state->{finalscores}}) { - $self->send_message($self->{channel}, "$color{green}Final scores: $color{reset}none"); - return 'next'; + push @{$state->{finalscores}}, $mentions if length $mentions; } - if ($state->{first_tock}) { - $self->send_message($self->{channel}, "$color{green}Final scores:$color{reset}"); - return 'wait'; - } + my $tock; + if ($state->{first_tock}) { $tock = 2; } + else { $tock = 3; } - my $text = shift @{$state->{finalscores}}; - $self->send_message($self->{channel}, "$text"); + if ($state->{ticks} % $tock == 0) { + $state->{tocked} = 1; - if (not @{$state->{finalscores}}) { - return 'next'; + if (not @{$state->{finalscores}}) { + $self->send_message($self->{channel}, "$color{green}Final scores: $color{reset}none"); + return 'next'; + } + + if ($state->{first_tock}) { + $self->send_message($self->{channel}, "$color{green}Final scores:$color{reset}"); + return 'wait'; + } + + my $text = shift @{$state->{finalscores}}; + $self->send_message($self->{channel}, "$text"); + + if (not @{$state->{finalscores}}) { return 'next'; } + else { return 'wait'; } } else { - return 'wait'; + return 'wait'; } - } else { - return 'wait'; - } } # state subroutines sub nogame { - my ($self, $state) = @_; - if ($self->{stats_running}) { - $self->{stats}->end; - delete $self->{stats_running}; - } - $state->{result} = 'nogame'; - return $state; + my ($self, $state) = @_; + if ($self->{stats_running}) { + $self->{stats}->end; + delete $self->{stats_running}; + } + $state->{result} = 'nogame'; + return $state; } sub getplayers { - my ($self, $state) = @_; + my ($self, $state) = @_; - my $players = $state->{players}; + my $players = $state->{players}; - my @names; - my $unready = @$players ? @$players : 1; + my @names; + my $unready = @$players ? @$players : 1; - foreach my $player (@$players) { - if (not $player->{ready}) { - push @names, "$player->{name} $color{red}(not ready)$color{reset}"; - } else { - $unready--; - push @names, $player->{name}; - } - } - - my $min_players = $self->{metadata}->get_data('settings', 'min_players') // 2; - - if (@$players >= $min_players and not $unready) { - $self->send_message($self->{channel}, "All players ready!"); - $state->{result} = 'allready'; - return $state; - } - - my $tock; - if ($state->{first_tock}) { - $tock = $self->{tock_duration}; - } else { - $tock = 300; - } - - if ($state->{ticks} % $tock == 0) { - $state->{tocked} = 1; - - if (not $unready) { - $self->send_message($self->{channel}, "Game cannot begin with one player."); + foreach my $player (@$players) { + if (not $player->{ready}) { push @names, "$player->{name} $color{red}(not ready)$color{reset}"; } + else { + $unready--; + push @names, $player->{name}; + } } - if (++$state->{counter} > 6) { - $self->send_message($self->{channel}, "Not all players were ready in time. The game has been stopped."); - $state->{result} = 'stop'; - $state->{players} = []; - return $state; - } + my $min_players = $self->{metadata}->get_data('settings', 'min_players') // 2; - $players = join ', ', @names; - - if (not @names) { - $players = 'none'; - - if ($state->{counter} >= 0) { - $self->send_message($self->{channel}, "All players have left the queue. The game has been stopped."); - $self->{current_state} = 'nogame'; - $self->{result} = 'nogame'; + if (@$players >= $min_players and not $unready) { + $self->send_message($self->{channel}, "All players ready!"); + $state->{result} = 'allready'; return $state; - } } - my $msg = "Waiting for more players or for all players to ready up. Current players: $players"; - $self->send_message($self->{channel}, "$msg"); - } + my $tock; + if ($state->{first_tock}) { $tock = $self->{tock_duration}; } + else { $tock = 300; } - $state->{result} = 'wait'; - return $state; + if ($state->{ticks} % $tock == 0) { + $state->{tocked} = 1; + + if (not $unready) { $self->send_message($self->{channel}, "Game cannot begin with one player."); } + + if (++$state->{counter} > 6) { + $self->send_message($self->{channel}, "Not all players were ready in time. The game has been stopped."); + $state->{result} = 'stop'; + $state->{players} = []; + return $state; + } + + $players = join ', ', @names; + + if (not @names) { + $players = 'none'; + + if ($state->{counter} >= 0) { + $self->send_message($self->{channel}, "All players have left the queue. The game has been stopped."); + $self->{current_state} = 'nogame'; + $self->{result} = 'nogame'; + return $state; + } + } + + my $msg = "Waiting for more players or for all players to ready up. Current players: $players"; + $self->send_message($self->{channel}, "$msg"); + } + + $state->{result} = 'wait'; + return $state; } sub round1 { - my ($self, $state) = @_; - if ($self->{metadata}->get_data('settings', 'stats')) { - $self->{stats}->begin; - $self->{stats_running} = 1; - } - $state->{truth_points} = 500; - $state->{lie_points} = 1000; - $state->{my_lie_points} = $state->{lie_points} * 0.25; - $state->{result} = 'next'; - return $state; + my ($self, $state) = @_; + if ($self->{metadata}->get_data('settings', 'stats')) { + $self->{stats}->begin; + $self->{stats_running} = 1; + } + $state->{truth_points} = 500; + $state->{lie_points} = 1000; + $state->{my_lie_points} = $state->{lie_points} * 0.25; + $state->{result} = 'next'; + return $state; } sub round1q1 { - my ($self, $state) = @_; - if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { - $state->{init} = 1; - $state->{counter} = 0; - $state->{max_count} = $self->{choosecategory_max_count}; - $self->send_message($self->{channel}, "Round 1/3, question 1/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") unless $state->{reroll_category}; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + my ($self, $state) = @_; + if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { + $state->{init} = 1; + $state->{counter} = 0; + $state->{max_count} = $self->{choosecategory_max_count}; + $self->send_message($self->{channel}, "Round 1/3, question 1/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") + unless $state->{reroll_category}; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r1q1choosecategory { - my ($self, $state) = @_; - $state->{result} = $self->choosecategory($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->choosecategory($state); + return $state; } sub r1q1showquestion { - my ($self, $state) = @_; - my $result = $self->getnewquestion($state); + my ($self, $state) = @_; + my $result = $self->getnewquestion($state); - if ($result eq 'next') { - $self->showquestion($state); - $state->{max_count} = $self->{picktruth_max_count}; - $state->{counter} = 0; - $state->{init} = 1; - $state->{current_lie_player} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + if ($result eq 'next') { + $self->showquestion($state); + $state->{max_count} = $self->{picktruth_max_count}; + $state->{counter} = 0; + $state->{init} = 1; + $state->{current_lie_player} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r1q1getlies { - my ($self, $state) = @_; - $state->{result} = $self->getlies($state); + my ($self, $state) = @_; + $state->{result} = $self->getlies($state); - if ($state->{result} eq 'next') { - $state->{counter} = 0; - $state->{init} = 1; - } + if ($state->{result} eq 'next') { + $state->{counter} = 0; + $state->{init} = 1; + } - return $state; + return $state; } sub r1q1findtruth { - my ($self, $state) = @_; - $state->{result} = $self->findtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->findtruth($state); + return $state; } sub r1q1showlies { - my ($self, $state) = @_; - $state->{result} = $self->showlies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showlies($state); + return $state; } sub r1q1showtruth { - my ($self, $state) = @_; - $state->{result} = $self->showtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showtruth($state); + return $state; } sub r1q1reveallies { - my ($self, $state) = @_; - $state->{result} = $self->reveallies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->reveallies($state); + return $state; } sub r1q1showscore { - my ($self, $state) = @_; - $state->{result} = $self->showscore($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showscore($state); + return $state; } sub round1q2 { - my ($self, $state) = @_; - if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { - $state->{init} = 1; - $state->{counter} = 0; - $state->{max_count} = $self->{choosecategory_max_count}; - $self->send_message($self->{channel}, "Round 1/3, question 2/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") unless $state->{reroll_category}; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + my ($self, $state) = @_; + if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { + $state->{init} = 1; + $state->{counter} = 0; + $state->{max_count} = $self->{choosecategory_max_count}; + $self->send_message($self->{channel}, "Round 1/3, question 2/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") + unless $state->{reroll_category}; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r1q2choosecategory { - my ($self, $state) = @_; - $state->{result} = $self->choosecategory($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->choosecategory($state); + return $state; } sub r1q2showquestion { - my ($self, $state) = @_; - my $result = $self->getnewquestion($state); + my ($self, $state) = @_; + my $result = $self->getnewquestion($state); - if ($result eq 'next') { - $self->showquestion($state); - $state->{max_count} = $self->{picktruth_max_count}; - $state->{counter} = 0; - $state->{init} = 1; - $state->{current_lie_player} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + if ($result eq 'next') { + $self->showquestion($state); + $state->{max_count} = $self->{picktruth_max_count}; + $state->{counter} = 0; + $state->{init} = 1; + $state->{current_lie_player} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r1q2getlies { - my ($self, $state) = @_; - $state->{result} = $self->getlies($state); + my ($self, $state) = @_; + $state->{result} = $self->getlies($state); - if ($state->{result} eq 'next') { - $state->{counter} = 0; - $state->{init} = 1; - } + if ($state->{result} eq 'next') { + $state->{counter} = 0; + $state->{init} = 1; + } - return $state; + return $state; } sub r1q2findtruth { - my ($self, $state) = @_; - $state->{result} = $self->findtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->findtruth($state); + return $state; } sub r1q2showlies { - my ($self, $state) = @_; - $state->{result} = $self->showlies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showlies($state); + return $state; } sub r1q2showtruth { - my ($self, $state) = @_; - $state->{result} = $self->showtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showtruth($state); + return $state; } sub r1q2reveallies { - my ($self, $state) = @_; - $state->{result} = $self->reveallies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->reveallies($state); + return $state; } sub r1q2showscore { - my ($self, $state) = @_; - $state->{result} = $self->showscore($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showscore($state); + return $state; } sub round1q3 { - my ($self, $state) = @_; - if ($state->{ticks} % 2 || $state->{reroll_category}) { - $state->{init} = 1; - $state->{max_count} = $self->{choosecategory_max_count}; - $state->{counter} = 0; - $state->{result} = 'wait'; - $self->send_message($self->{channel}, "Round 1/3, question 3/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") unless $state->{reroll_category}; - } else { - $state->{result} = 'next'; - } - return $state; + my ($self, $state) = @_; + if ($state->{ticks} % 2 || $state->{reroll_category}) { + $state->{init} = 1; + $state->{max_count} = $self->{choosecategory_max_count}; + $state->{counter} = 0; + $state->{result} = 'wait'; + $self->send_message($self->{channel}, "Round 1/3, question 3/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") + unless $state->{reroll_category}; + } else { + $state->{result} = 'next'; + } + return $state; } sub r1q3choosecategory { - my ($self, $state) = @_; - $state->{result} = $self->choosecategory($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->choosecategory($state); + return $state; } sub r1q3showquestion { - my ($self, $state) = @_; - my $result = $self->getnewquestion($state); + my ($self, $state) = @_; + my $result = $self->getnewquestion($state); - if ($result eq 'next') { - $self->showquestion($state); - $state->{max_count} = $self->{picktruth_max_count}; - $state->{counter} = 0; - $state->{init} = 1; - $state->{current_lie_player} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + if ($result eq 'next') { + $self->showquestion($state); + $state->{max_count} = $self->{picktruth_max_count}; + $state->{counter} = 0; + $state->{init} = 1; + $state->{current_lie_player} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r1q3getlies { - my ($self, $state) = @_; - $state->{result} = $self->getlies($state); + my ($self, $state) = @_; + $state->{result} = $self->getlies($state); - if ($state->{result} eq 'next') { - $state->{counter} = 0; - $state->{init} = 1; - } + if ($state->{result} eq 'next') { + $state->{counter} = 0; + $state->{init} = 1; + } - return $state; + return $state; } sub r1q3findtruth { - my ($self, $state) = @_; - $state->{result} = $self->findtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->findtruth($state); + return $state; } sub r1q3showlies { - my ($self, $state) = @_; - $state->{result} = $self->showlies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showlies($state); + return $state; } sub r1q3showtruth { - my ($self, $state) = @_; - $state->{result} = $self->showtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showtruth($state); + return $state; } sub r1q3reveallies { - my ($self, $state) = @_; - $state->{result} = $self->reveallies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->reveallies($state); + return $state; } sub r1q3showscore { - my ($self, $state) = @_; - $state->{result} = $self->showscore($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showscore($state); + return $state; } sub round2 { - my ($self, $state) = @_; - $state->{truth_points} = 750; - $state->{lie_points} = 1500; - $state->{my_lie_points} = $state->{lie_points} * 0.25; - $state->{result} = 'next'; - return $state; + my ($self, $state) = @_; + $state->{truth_points} = 750; + $state->{lie_points} = 1500; + $state->{my_lie_points} = $state->{lie_points} * 0.25; + $state->{result} = 'next'; + return $state; } sub round2q1 { - my ($self, $state) = @_; - if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { - $state->{init} = 1; - $state->{max_count} = $self->{choosecategory_max_count}; - $state->{counter} = 0; - $self->send_message($self->{channel}, "Round 2/3, question 1/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") unless $state->{reroll_category}; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + my ($self, $state) = @_; + if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { + $state->{init} = 1; + $state->{max_count} = $self->{choosecategory_max_count}; + $state->{counter} = 0; + $self->send_message($self->{channel}, "Round 2/3, question 1/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") + unless $state->{reroll_category}; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r2q1choosecategory { - my ($self, $state) = @_; - $state->{result} = $self->choosecategory($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->choosecategory($state); + return $state; } sub r2q1showquestion { - my ($self, $state) = @_; - my $result = $self->getnewquestion($state); + my ($self, $state) = @_; + my $result = $self->getnewquestion($state); - if ($result eq 'next') { - $self->showquestion($state); - $state->{max_count} = $self->{picktruth_max_count}; - $state->{counter} = 0; - $state->{init} = 1; - $state->{current_lie_player} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + if ($result eq 'next') { + $self->showquestion($state); + $state->{max_count} = $self->{picktruth_max_count}; + $state->{counter} = 0; + $state->{init} = 1; + $state->{current_lie_player} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r2q1getlies { - my ($self, $state) = @_; - $state->{result} = $self->getlies($state); + my ($self, $state) = @_; + $state->{result} = $self->getlies($state); - if ($state->{result} eq 'next') { - $state->{counter} = 0; - $state->{init} = 1; - } + if ($state->{result} eq 'next') { + $state->{counter} = 0; + $state->{init} = 1; + } - return $state; + return $state; } sub r2q1findtruth { - my ($self, $state) = @_; - $state->{result} = $self->findtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->findtruth($state); + return $state; } sub r2q1showlies { - my ($self, $state) = @_; - $state->{result} = $self->showlies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showlies($state); + return $state; } sub r2q1showtruth { - my ($self, $state) = @_; - $state->{result} = $self->showtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showtruth($state); + return $state; } sub r2q1reveallies { - my ($self, $state) = @_; - $state->{result} = $self->reveallies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->reveallies($state); + return $state; } sub r2q1showscore { - my ($self, $state) = @_; - $state->{result} = $self->showscore($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showscore($state); + return $state; } sub round2q2 { - my ($self, $state) = @_; - if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { - $state->{init} = 1; - $state->{max_count} = $self->{choosecategory_max_count}; - $state->{counter} = 0; - $self->send_message($self->{channel}, "Round 2/3, question 2/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") unless $state->{reroll_category}; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + my ($self, $state) = @_; + if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { + $state->{init} = 1; + $state->{max_count} = $self->{choosecategory_max_count}; + $state->{counter} = 0; + $self->send_message($self->{channel}, "Round 2/3, question 2/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") + unless $state->{reroll_category}; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r2q2choosecategory { - my ($self, $state) = @_; - $state->{result} = $self->choosecategory($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->choosecategory($state); + return $state; } sub r2q2showquestion { - my ($self, $state) = @_; - my $result = $self->getnewquestion($state); + my ($self, $state) = @_; + my $result = $self->getnewquestion($state); - if ($result eq 'next') { - $self->showquestion($state); - $state->{max_count} = $self->{picktruth_max_count}; - $state->{counter} = 0; - $state->{init} = 1; - $state->{current_lie_player} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + if ($result eq 'next') { + $self->showquestion($state); + $state->{max_count} = $self->{picktruth_max_count}; + $state->{counter} = 0; + $state->{init} = 1; + $state->{current_lie_player} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r2q2getlies { - my ($self, $state) = @_; - $state->{result} = $self->getlies($state); + my ($self, $state) = @_; + $state->{result} = $self->getlies($state); - if ($state->{result} eq 'next') { - $state->{counter} = 0; - $state->{init} = 1; - } + if ($state->{result} eq 'next') { + $state->{counter} = 0; + $state->{init} = 1; + } - return $state; + return $state; } sub r2q2findtruth { - my ($self, $state) = @_; - $state->{result} = $self->findtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->findtruth($state); + return $state; } sub r2q2showlies { - my ($self, $state) = @_; - $state->{result} = $self->showlies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showlies($state); + return $state; } sub r2q2showtruth { - my ($self, $state) = @_; - $state->{result} = $self->showtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showtruth($state); + return $state; } sub r2q2reveallies { - my ($self, $state) = @_; - $state->{result} = $self->reveallies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->reveallies($state); + return $state; } sub r2q2showscore { - my ($self, $state) = @_; - $state->{result} = $self->showscore($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showscore($state); + return $state; } sub round2q3 { - my ($self, $state) = @_; - if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { - $state->{init} = 1; - $state->{max_count} = $self->{choosecategory_max_count}; - $state->{counter} = 0; - $self->send_message($self->{channel}, "Round 2/3, question 3/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") unless $state->{reroll_category}; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + my ($self, $state) = @_; + if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { + $state->{init} = 1; + $state->{max_count} = $self->{choosecategory_max_count}; + $state->{counter} = 0; + $self->send_message($self->{channel}, "Round 2/3, question 3/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") + unless $state->{reroll_category}; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r2q3choosecategory { - my ($self, $state) = @_; - $state->{result} = $self->choosecategory($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->choosecategory($state); + return $state; } sub r2q3showquestion { - my ($self, $state) = @_; - my $result = $self->getnewquestion($state); + my ($self, $state) = @_; + my $result = $self->getnewquestion($state); - if ($result eq 'next') { - $self->showquestion($state); - $state->{max_count} = $self->{picktruth_max_count}; - $state->{counter} = 0; - $state->{init} = 1; - $state->{current_lie_player} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + if ($result eq 'next') { + $self->showquestion($state); + $state->{max_count} = $self->{picktruth_max_count}; + $state->{counter} = 0; + $state->{init} = 1; + $state->{current_lie_player} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r2q3getlies { - my ($self, $state) = @_; - $state->{result} = $self->getlies($state); + my ($self, $state) = @_; + $state->{result} = $self->getlies($state); - if ($state->{result} eq 'next') { - $state->{counter} = 0; - $state->{init} = 1; - } + if ($state->{result} eq 'next') { + $state->{counter} = 0; + $state->{init} = 1; + } - return $state; + return $state; } sub r2q3findtruth { - my ($self, $state) = @_; - $state->{result} = $self->findtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->findtruth($state); + return $state; } sub r2q3showlies { - my ($self, $state) = @_; - $state->{result} = $self->showlies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showlies($state); + return $state; } sub r2q3showtruth { - my ($self, $state) = @_; - $state->{result} = $self->showtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showtruth($state); + return $state; } sub r2q3reveallies { - my ($self, $state) = @_; - $state->{result} = $self->reveallies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->reveallies($state); + return $state; } sub r2q3showscore { - my ($self, $state) = @_; - $state->{result} = $self->showscore($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showscore($state); + return $state; } sub round3 { - my ($self, $state) = @_; - $state->{truth_points} = 1000; - $state->{lie_points} = 2000; - $state->{my_lie_points} = $state->{lie_points} * 0.25; - $state->{result} = 'next'; - return $state; + my ($self, $state) = @_; + $state->{truth_points} = 1000; + $state->{lie_points} = 2000; + $state->{my_lie_points} = $state->{lie_points} * 0.25; + $state->{result} = 'next'; + return $state; } sub round3q1 { - my ($self, $state) = @_; - if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { - $state->{init} = 1; - $state->{max_count} = $self->{choosecategory_max_count}; - $state->{counter} = 0; - $self->send_message($self->{channel}, "Round 3/3, question 1/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") unless $state->{reroll_category}; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + my ($self, $state) = @_; + if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { + $state->{init} = 1; + $state->{max_count} = $self->{choosecategory_max_count}; + $state->{counter} = 0; + $self->send_message($self->{channel}, "Round 3/3, question 1/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") + unless $state->{reroll_category}; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r3q1choosecategory { - my ($self, $state) = @_; - $state->{result} = $self->choosecategory($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->choosecategory($state); + return $state; } sub r3q1showquestion { - my ($self, $state) = @_; - my $result = $self->getnewquestion($state); + my ($self, $state) = @_; + my $result = $self->getnewquestion($state); - if ($result eq 'next') { - $self->showquestion($state); - $state->{max_count} = $self->{picktruth_max_count}; - $state->{counter} = 0; - $state->{init} = 1; - $state->{current_lie_player} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + if ($result eq 'next') { + $self->showquestion($state); + $state->{max_count} = $self->{picktruth_max_count}; + $state->{counter} = 0; + $state->{init} = 1; + $state->{current_lie_player} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r3q1getlies { - my ($self, $state) = @_; - $state->{result} = $self->getlies($state); + my ($self, $state) = @_; + $state->{result} = $self->getlies($state); - if ($state->{result} eq 'next') { - $state->{counter} = 0; - $state->{init} = 1; - } + if ($state->{result} eq 'next') { + $state->{counter} = 0; + $state->{init} = 1; + } - return $state; + return $state; } sub r3q1findtruth { - my ($self, $state) = @_; - $state->{result} = $self->findtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->findtruth($state); + return $state; } sub r3q1showlies { - my ($self, $state) = @_; - $state->{result} = $self->showlies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showlies($state); + return $state; } sub r3q1showtruth { - my ($self, $state) = @_; - $state->{result} = $self->showtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showtruth($state); + return $state; } sub r3q1reveallies { - my ($self, $state) = @_; - $state->{result} = $self->reveallies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->reveallies($state); + return $state; } sub r3q1showscore { - my ($self, $state) = @_; - $state->{result} = $self->showscore($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showscore($state); + return $state; } sub round3q2 { - my ($self, $state) = @_; - if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { - $state->{init} = 1; - $state->{max_count} = $self->{choosecategory_max_count}; - $state->{counter} = 0; - $self->send_message($self->{channel}, "Round 3/3, question 2/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") unless $state->{reroll_category}; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + my ($self, $state) = @_; + if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { + $state->{init} = 1; + $state->{max_count} = $self->{choosecategory_max_count}; + $state->{counter} = 0; + $self->send_message($self->{channel}, "Round 3/3, question 2/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") + unless $state->{reroll_category}; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r3q2choosecategory { - my ($self, $state) = @_; - $state->{result} = $self->choosecategory($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->choosecategory($state); + return $state; } sub r3q2showquestion { - my ($self, $state) = @_; - my $result = $self->getnewquestion($state); + my ($self, $state) = @_; + my $result = $self->getnewquestion($state); - if ($result eq 'next') { - $self->showquestion($state); - $state->{max_count} = $self->{picktruth_max_count}; - $state->{counter} = 0; - $state->{init} = 1; - $state->{current_lie_player} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + if ($result eq 'next') { + $self->showquestion($state); + $state->{max_count} = $self->{picktruth_max_count}; + $state->{counter} = 0; + $state->{init} = 1; + $state->{current_lie_player} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r3q2getlies { - my ($self, $state) = @_; - $state->{result} = $self->getlies($state); + my ($self, $state) = @_; + $state->{result} = $self->getlies($state); - if ($state->{result} eq 'next') { - $state->{counter} = 0; - $state->{init} = 1; - } + if ($state->{result} eq 'next') { + $state->{counter} = 0; + $state->{init} = 1; + } - return $state; + return $state; } sub r3q2findtruth { - my ($self, $state) = @_; - $state->{result} = $self->findtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->findtruth($state); + return $state; } sub r3q2showlies { - my ($self, $state) = @_; - $state->{result} = $self->showlies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showlies($state); + return $state; } sub r3q2showtruth { - my ($self, $state) = @_; - $state->{result} = $self->showtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showtruth($state); + return $state; } sub r3q2reveallies { - my ($self, $state) = @_; - $state->{result} = $self->reveallies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->reveallies($state); + return $state; } sub r3q2showscore { - my ($self, $state) = @_; - $state->{result} = $self->showscore($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showscore($state); + return $state; } sub round3q3 { - my ($self, $state) = @_; - if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { - $state->{init} = 1; - $state->{max_count} = $self->{choosecategory_max_count}; - $state->{counter} = 0; - $self->send_message($self->{channel}, "Round 3/3, question 3/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") unless $state->{reroll_category}; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + my ($self, $state) = @_; + if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { + $state->{init} = 1; + $state->{max_count} = $self->{choosecategory_max_count}; + $state->{counter} = 0; + $self->send_message($self->{channel}, "Round 3/3, question 3/3! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") + unless $state->{reroll_category}; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r3q3choosecategory { - my ($self, $state) = @_; - $state->{result} = $self->choosecategory($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->choosecategory($state); + return $state; } sub r3q3showquestion { - my ($self, $state) = @_; - my $result = $self->getnewquestion($state); + my ($self, $state) = @_; + my $result = $self->getnewquestion($state); - if ($result eq 'next') { - $self->showquestion($state); - $state->{max_count} = $self->{picktruth_max_count}; - $state->{counter} = 0; - $state->{init} = 1; - $state->{current_lie_player} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + if ($result eq 'next') { + $self->showquestion($state); + $state->{max_count} = $self->{picktruth_max_count}; + $state->{counter} = 0; + $state->{init} = 1; + $state->{current_lie_player} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r3q3getlies { - my ($self, $state) = @_; - $state->{result} = $self->getlies($state); + my ($self, $state) = @_; + $state->{result} = $self->getlies($state); - if ($state->{result} eq 'next') { - $state->{counter} = 0; - $state->{init} = 1; - } + if ($state->{result} eq 'next') { + $state->{counter} = 0; + $state->{init} = 1; + } - return $state; + return $state; } sub r3q3findtruth { - my ($self, $state) = @_; - $state->{result} = $self->findtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->findtruth($state); + return $state; } sub r3q3showlies { - my ($self, $state) = @_; - $state->{result} = $self->showlies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showlies($state); + return $state; } sub r3q3showtruth { - my ($self, $state) = @_; - $state->{result} = $self->showtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showtruth($state); + return $state; } sub r3q3reveallies { - my ($self, $state) = @_; - $state->{result} = $self->reveallies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->reveallies($state); + return $state; } sub r3q3showscore { - my ($self, $state) = @_; - $state->{result} = $self->showscore($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showscore($state); + return $state; } sub round4 { - my ($self, $state) = @_; - $state->{truth_points} = 2000; - $state->{lie_points} = 3000; - $state->{my_lie_points} = $state->{lie_points} * 0.25; - $state->{result} = 'next'; - return $state; + my ($self, $state) = @_; + $state->{truth_points} = 2000; + $state->{lie_points} = 3000; + $state->{my_lie_points} = $state->{lie_points} * 0.25; + $state->{result} = 'next'; + return $state; } sub round4q1 { - my ($self, $state) = @_; - if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { - $state->{init} = 1; - $state->{random_category} = 1; - $state->{max_count} = $self->{choosecategory_max_count}; - $state->{counter} = 0; - $self->send_message($self->{channel}, "FINAL ROUND! FINAL QUESTION! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") unless $state->{reroll_category}; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + my ($self, $state) = @_; + if ($state->{ticks} % 2 == 0 || $state->{reroll_category}) { + $state->{init} = 1; + $state->{random_category} = 1; + $state->{max_count} = $self->{choosecategory_max_count}; + $state->{counter} = 0; + $self->send_message($self->{channel}, "FINAL ROUND! FINAL QUESTION! $state->{lie_points} for each lie. $state->{truth_points} for the truth.") + unless $state->{reroll_category}; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r4q1choosecategory { - my ($self, $state) = @_; - $state->{result} = $self->choosecategory($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->choosecategory($state); + return $state; } sub r4q1showquestion { - my ($self, $state) = @_; - my $result = $self->getnewquestion($state); + my ($self, $state) = @_; + my $result = $self->getnewquestion($state); - if ($result eq 'next') { - $self->showquestion($state); - $state->{max_count} = $self->{picktruth_max_count}; - $state->{counter} = 0; - $state->{init} = 1; - $state->{current_lie_player} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + if ($result eq 'next') { + $self->showquestion($state); + $state->{max_count} = $self->{picktruth_max_count}; + $state->{counter} = 0; + $state->{init} = 1; + $state->{current_lie_player} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; + } + return $state; } sub r4q1getlies { - my ($self, $state) = @_; - $state->{result} = $self->getlies($state); + my ($self, $state) = @_; + $state->{result} = $self->getlies($state); - if ($state->{result} eq 'next') { - $state->{counter} = 0; - $state->{init} = 1; - } + if ($state->{result} eq 'next') { + $state->{counter} = 0; + $state->{init} = 1; + } - return $state; + return $state; } sub r4q1findtruth { - my ($self, $state) = @_; - $state->{result} = $self->findtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->findtruth($state); + return $state; } sub r4q1showlies { - my ($self, $state) = @_; - $state->{result} = $self->showlies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showlies($state); + return $state; } sub r4q1showtruth { - my ($self, $state) = @_; - $state->{result} = $self->showtruth($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showtruth($state); + return $state; } sub r4q1reveallies { - my ($self, $state) = @_; - $state->{result} = $self->reveallies($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->reveallies($state); + return $state; } sub r4q1showscore { - my ($self, $state) = @_; - $state->{result} = $self->showfinalscore($state); - return $state; + my ($self, $state) = @_; + $state->{result} = $self->showfinalscore($state); + return $state; } sub gameover { - my ($self, $state) = @_; + my ($self, $state) = @_; - if ($state->{ticks} % 3 == 0) { - $self->send_message($self->{channel}, "Game over!"); + if ($state->{ticks} % 3 == 0) { + $self->send_message($self->{channel}, "Game over!"); - my $players = $state->{players}; - foreach my $player (@$players) { - $player->{ready} = 0; - $player->{missedinputs} = 0; + my $players = $state->{players}; + foreach my $player (@$players) { + $player->{ready} = 0; + $player->{missedinputs} = 0; + } + + # save updated seen_timestamps + $self->save_questions; + + $state->{counter} = 0; + $state->{result} = 'next'; + } else { + $state->{result} = 'wait'; } - - # save updated seen_timestamps - $self->save_questions; - - $state->{counter} = 0; - $state->{result} = 'next'; - } else { - $state->{result} = 'wait'; - } - return $state; + return $state; } 1; diff --git a/Plugins/Spinach/Rank.pm b/Plugins/Spinach/Rank.pm index c1f69305..f48d0404 100644 --- a/Plugins/Spinach/Rank.pm +++ b/Plugins/Spinach/Rank.pm @@ -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 [-] [offset] or rank [-]; 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 "; + if (not $arguments) { + my $result = "Usage: rank [-] [offset] or rank [-]; 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 "; } + } + + 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; diff --git a/Plugins/Spinach/Stats.pm b/Plugins/Spinach/Stats.pm index e704d33a..e87e1f6d 100644 --- a/Plugins/Spinach/Stats.pm +++ b/Plugins/Spinach/Stats.pm @@ -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; diff --git a/Plugins/Spinach/update_seent.pl b/Plugins/Spinach/update_seent.pl index 3de37a6e..3f7fda65 100644 --- a/Plugins/Spinach/update_seent.pl +++ b/Plugins/Spinach/update_seent.pl @@ -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; diff --git a/Plugins/TypoSub.pm b/Plugins/TypoSub.pm index ae3fee6b..aff33c61 100644 --- a/Plugins/TypoSub.pm +++ b/Plugins/TypoSub.pm @@ -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}(.*?)(?{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; diff --git a/Plugins/UrlTitles.pm b/Plugins/UrlTitles.pm index 7d197abb..499c426a 100644 --- a/Plugins/UrlTitles.pm +++ b/Plugins/UrlTitles.pm @@ -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; diff --git a/Plugins/Weather.pm b/Plugins/Weather.pm index f219ae83..b43af870 100644 --- a/Plugins/Weather.pm +++ b/Plugins/Weather.pm @@ -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 ] [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 ] [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 \", \" (e.g. \"paris, fr\") or a US Zip Code or \", , 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 \", \" (e.g. \"paris, fr\") or a US Zip Code or \", , 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/ fix_temps($description); + $result .= "Forecast: $description"; + last; + } } - - if ($title =~ m/Forecast$/) { - $description =~ s/ 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; diff --git a/Plugins/Wttr.pm b/Plugins/Wttr.pm index cf93a38f..80929e0b 100644 --- a/Plugins/Wttr.pm +++ b/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 ] [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 ] [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; diff --git a/misc/tidy b/misc/tidy new file mode 100644 index 00000000..de6436ff --- /dev/null +++ b/misc/tidy @@ -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 $* diff --git a/modules/ago.pl b/modules/ago.pl index 76da00c8..ec98aadb 100755 --- a/modules/ago.pl +++ b/modules/ago.pl @@ -9,8 +9,8 @@ use Time::Duration; my ($ago) = @ARGV; if (not defined $ago) { - print "Usage: ago \n"; - exit 0; + print "Usage: ago \n"; + exit 0; } print ago_exact($ago), "\n"; diff --git a/modules/c11std.pl b/modules/c11std.pl index d3d7bdb7..e22d05f7 100755 --- a/modules/c11std.pl +++ b/modules/c11std.pl @@ -16,57 +16,55 @@ my $RESULTS_SPECIFIED = 2; my $search = join ' ', @ARGV; if (not length $search) { - print "Usage: c11std [-list] [-n#] [-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
] [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, "= 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*$//; diff --git a/modules/c2english.pl b/modules/c2english.pl index dbb15088..6eec5bc2 100755 --- a/modules/c2english.pl +++ b/modules/c2english.pl @@ -17,19 +17,18 @@ my $debug = 0; my $code = join ' ', @ARGV; if (not length $code) { - print "Usage: english \n"; - exit; + print "Usage: english \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 \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#define _Atomic\n#define _Static_assert(a, b)\n\n"; +my $prelude_base = + "#define _XOPEN_SOURCE 9001\n#define __USE_XOPEN\n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \n#include \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; + 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; + + 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})' ,? ?"/\\$1/g; - $output =~ s/, '\\(\d{3})' \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///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/, //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})' ,? ?"/\\$1/g; + $output =~ s/, '\\(\d{3})' \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///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/, //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); } diff --git a/modules/c99std.pl b/modules/c99std.pl index 19e6048c..f525e92e 100755 --- a/modules/c99std.pl +++ b/modules/c99std.pl @@ -16,57 +16,55 @@ my $RESULTS_SPECIFIED = 2; my $search = join ' ', @ARGV; if (not length $search) { - print "Usage: c99std [-list] [-n#] [-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
] [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, "= 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*$//; diff --git a/modules/cdecl.pl b/modules/cdecl.pl index c5bcbf1c..79d06b25 100755 --- a/modules/cdecl.pl +++ b/modules/cdecl.pl @@ -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 , see http://linux.die.net/man/1/cdecl (Don't use this command. Use `english` instead.)\n"; - die; + print "Usage: cdecl , 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"; diff --git a/modules/cfaq.pl b/modules/cfaq.pl index 5d6b8b09..040ee42d 100755 --- a/modules/cfaq.pl +++ b/modules/cfaq.pl @@ -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 #] \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>/) { - $heading = $1; - next; - } - - if ($line =~ m/

(.*?)<\/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>/) { + $heading = $1; + next; } - $question_full = "$question_number $question_link "; - $question_text = "http://c-faq.com/$question_link - $heading, $question_number: "; - next; - } + if ($line =~ m/

(.*?)<\/a>/) { + ($question_link, $question_number) = ($1, $2); - if (defined $question_full) { - $line =~ s/[\n\r]/ /g; - $line =~ s/(

|<\/pre>||<\/TT>|<\/a>|
)//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>||<\/TT>|<\/a>|
)//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";
 }
diff --git a/modules/codepad.pl b/modules/codepad.pl
index 3aa06edc..eb6adff7 100755
--- a/modules/codepad.pl
+++ b/modules/codepad.pl
@@ -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 \n#include \n#include \n",
-                 'C++' => "#include \n#include \n",
-               );
+my %preludes = (
+    'C'   => "#include \n#include \n#include \n",
+    'C++' => "#include \n#include \n",
+);
 
 if ($#ARGV <= 0) {
-  print "Usage: cc [-lang=] \n";
-  exit 0;
+    print "Usage: cc [-lang=] \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 .= "
error: unmatched brackets for function '$ident'; 
";
-      $body = $extract[1];
-    } else {
-      $body = $extract[0];
-      $precode .= $extract[1];
+        my @extract = extract_codeblock($potential_body, '{}');
+        my $body;
+        if (not defined $extract[0]) {
+            $output .= "
error: unmatched brackets for function '$ident'; 
";
+            $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/\d+<\/a>//g;
 
-if ($text =~ /Output:<\/span>.+?
(.*)<\/div>.+?<\/table>/si) {
-  $output .= "$1";
-} else {
-  $output .= "
No output.
";
-}
+if   ($text =~ /Output:<\/span>.+?
(.*)<\/div>.+?<\/table>/si) { $output .= "$1"; }
+else                                                                                                  { $output .= "
No output.
"; }
 
 $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 = ) {
-    $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 = ) { $result .= $line; }
+    close IN;
+    waitpid($pid, 0);
+    return $result;
 }
 
diff --git a/modules/compiler_block.pl b/modules/compiler_block.pl
index 6abc8011..c49f2e83 100755
--- a/modules/compiler_block.pl
+++ b/modules/compiler_block.pl
@@ -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;
diff --git a/modules/compiler_client.pl b/modules/compiler_client.pl
index e7b6ccf8..9b9f6fc4 100755
--- a/modules/compiler_client.pl
+++ b/modules/compiler_client.pl
@@ -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;
diff --git a/modules/define.pl b/modules/define.pl
index 189bbfdf..899d3488 100755
--- a/modules/define.pl
+++ b/modules/define.pl
@@ -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>/g) {
+        print "Did you mean '$1'?  Alternate suggestions: ";
 
-  if ($text =~ m/Did you mean (.*?)<\/a>/g)
-  {
-    print "Did you mean '$1'?  Alternate suggestions: ";
-
-    $i = 90;
-    $comma = "";
-    while ($text =~ m/
  • (.*?)<\/a>/g && $i > 0)
-    {
-      print "$comma$1";
-      $i--;
-      $comma = ", ";
+        $i     = 90;
+        $comma = "";
+        while ($text =~ m/
  • (.*?)<\/a>/g && $i > 0) {
+            print "$comma$1";
+            $i--;
+            $comma = ", ";
+        }
     }
-  }
 
-#  if ($text =~ m/Encyclopedia suggestions:/g)
-#  {
-#    print "Suggestions: ";
-#
-#    $i = 30;
-#    while ($text =~ m/ $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>/gs)
-  {
-    $defint = $1;
-  }
+while ($i <= $entries) {
+    if ($text =~ m/(.*?)<\/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/Pronun.*?
    //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/Pronun.*?
    //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";
diff --git a/modules/dice_roll.pl b/modules/dice_roll.pl
index dd8bfe59..c228a0b3 100755
--- a/modules/dice_roll.pl
+++ b/modules/dice_roll.pl
@@ -10,36 +10,31 @@ use Games::Dice qw/roll roll_array/;
 
 my ($result, $rolls, $show);
 
-if ($#ARGV <0)
-{
-  print "Usage: roll [-show] ; e.g.: roll 3d6+1. To see all individual dice rolls, add -show.\n";
-  die;
+if ($#ARGV < 0) {
+    print "Usage: roll [-show] ; 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] ; e.g.: roll 3d6+1. To see all individual dice rolls, add -show.\n";
-  die;
+    print "Usage: roll [-show] ; 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";
 }
diff --git a/modules/dict.org.pl b/modules/dict.org.pl
index 5a29e2fa..410a8ae7 100755
--- a/modules/dict.org.pl
+++ b/modules/dict.org.pl
@@ -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  for definitions matching ] \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  for definitions matching ] \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  for definitions matching ] \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  for definitions matching ] \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
diff --git a/modules/expand_macros.pl b/modules/expand_macros.pl
index f168aa8b..69097987 100755
--- a/modules/expand_macros.pl
+++ b/modules/expand_macros.pl
@@ -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 \n";
-  exit 0;
+    print "Usage: expand \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;
+    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;
+
+        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);
 }
 
-
diff --git a/modules/funnyish_quote.pl b/modules/funnyish_quote.pl
index 84312b95..13baa615 100755
--- a/modules/funnyish_quote.pl
+++ b/modules/funnyish_quote.pl
@@ -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/
    (.*?)<\/a>.*?
    .*?(.*?)<\/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;
diff --git a/modules/gdefine.pl b/modules/gdefine.pl
index 34db1209..5771040c 100755
--- a/modules/gdefine.pl
+++ b/modules/gdefine.pl
@@ -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/
  • (.*?)
    /gs)
-  {
-    push @defs, $1;
-  }
-  $i++;
+while ($i <= $entry + 5) {
+    if ($text =~ m/
  • (.*?)
    /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/Pronun.*?
    //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/Pronun.*?
    //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 = ", ";
 }
diff --git a/modules/gen_cfacts.pl b/modules/gen_cfacts.pl
index c25294a7..0200d957 100644
--- a/modules/gen_cfacts.pl
+++ b/modules/gen_cfacts.pl
@@ -14,11 +14,12 @@ use HTML::Entities;
 my $STD = 'n1570.html';
 
 my $text;
+
 {
-  local $/ = undef;
-  open my $fh, "<", $STD or die "Could not open $STD: $!";
-  $text = <$fh>;
-  close $fh;
+    local $/ = undef;
+    open my $fh, "<", $STD or die "Could not open $STD: $!";
+    $text = <$fh>;
+    close $fh;
 }
 
 my $cfact_regex = qr/
@@ -42,38 +43,38 @@ my $cfact_regex = qr/
 
 my @sections;
 while ($text =~ /^
    (.*?)<\/h3>/mg) {
-  my $section = $1;
-  $section =~ s/[\[\]]//g;
-  unshift @sections, [pos $text, $section];
+    my $section = $1;
+    $section =~ s/[\[\]]//g;
+    unshift @sections, [pos $text, $section];
 }
 
 while ($text =~ /$cfact_regex/gms) {
-  my $fact = $1;
-  next unless length $fact;
+    my $fact = $1;
+    next unless length $fact;
 
-  $fact =~ s/[\n\r]/ /g;
-  $fact =~ s/ +/ /g;
-  $fact =~ s/^\.\s*//;
-  $fact =~ s/^\s*--\s*//;
-  $fact =~ s/^\d+\s*//;
-  $fact =~ s/- ([a-z])/-$1/g;
-  $fact =~ s/\s+\././g;
-  $fact =~ s/^\s*
    \s*\d*\s*//;
-  $fact =~ s/^\s*EXAMPLE\s*//;
-  $fact =~ s/^\s*NOTE\s*//;
-  $fact =~ s/^\s+//;
-  $fact =~ s/\s+$//;
+    $fact =~ s/[\n\r]/ /g;
+    $fact =~ s/ +/ /g;
+    $fact =~ s/^\.\s*//;
+    $fact =~ s/^\s*--\s*//;
+    $fact =~ s/^\d+\s*//;
+    $fact =~ s/- ([a-z])/-$1/g;
+    $fact =~ s/\s+\././g;
+    $fact =~ s/^\s*
    \s*\d*\s*//;
+    $fact =~ s/^\s*EXAMPLE\s*//;
+    $fact =~ s/^\s*NOTE\s*//;
+    $fact =~ s/^\s+//;
+    $fact =~ s/\s+$//;
 
-  my $section = '';
-  foreach my $s (@sections) {
-    if (pos $text >= $s->[0]) {
-      $section = "[$s->[1]] ";
-      last;
+    my $section = '';
+    foreach my $s (@sections) {
+        if (pos $text >= $s->[0]) {
+            $section = "[$s->[1]] ";
+            last;
+        }
     }
-  }
 
-  $fact = decode_entities($fact);
-  $fact =~ s/[a-z;,.]\K\d+\)//g; # remove footnote markers
+    $fact = decode_entities($fact);
+    $fact =~ s/[a-z;,.]\K\d+\)//g;    # remove footnote markers
 
-  print "$section$fact.\n";
+    print "$section$fact.\n";
 }
diff --git a/modules/gencstd.pl b/modules/gencstd.pl
index 35e3da79..d532302d 100755
--- a/modules/gencstd.pl
+++ b/modules/gencstd.pl
@@ -19,11 +19,11 @@ sub gen_txt;
 sub gen_html;
 
 open FH, ";
 close FH;
 
-
 my $text = join '', @contents;
 $text =~ s/\r//g;
 
@@ -31,173 +31,171 @@ my ($section_title, $this_section);
 
 my %sections;
 my $last_section_number = 0;
-my $section_number = 0;
+my $section_number      = 0;
 my $last_section;
 my @footnotes;
-my $footnote = 0;
+my $footnote      = 0;
 my $last_footnote = 0;
 
 gen_data;
+
 #gen_txt;
 gen_html;
 
 sub gen_data {
-  while ($text =~ m/^\s{0,5}([0-9A-Z]+\.[0-9\.]*)/msg) {
-    $last_section_number = $section_number;
-    $last_section = $this_section;
-    $this_section = $1;
+    while ($text =~ m/^\s{0,5}([0-9A-Z]+\.[0-9\.]*)/msg) {
+        $last_section_number = $section_number;
+        $last_section        = $this_section;
+        $this_section        = $1;
 
-    ($section_number) = $this_section =~ /([^.]+)\./;
+        ($section_number) = $this_section =~ /([^.]+)\./;
 
-    print STDERR "----------------------------------\n" if $debug;
-    print STDERR "Processing section [$this_section]; number [$section_number]\n" if $debug;
+        print STDERR "----------------------------------\n"                           if $debug;
+        print STDERR "Processing section [$this_section]; number [$section_number]\n" if $debug;
 
-    print STDERR "this_section: [$this_section]; last_section: [$last_section]\n" if $debug >= 2;
-    print STDERR "Section diff: ", ($this_section - $last_section), "\n" if $debug >= 2;
+        print STDERR "this_section: [$this_section]; last_section: [$last_section]\n" if $debug >= 2;
+        print STDERR "Section diff: ", ($this_section - $last_section), "\n" if $debug >= 2;
 
-    my $diff = $section_number - $last_section_number;
-    print STDERR "Diff: $diff\n" if $debug >= 2;
+        my $diff = $section_number - $last_section_number;
+        print STDERR "Diff: $diff\n" if $debug >= 2;
 
-    if ($section_number > 0 and $diff < 0 or $diff > 1) {
-      print STDERR "Diff out of bounds: $diff\n";
-      last;
-    }
-
-    my $section_text;
-
-    if ($text =~ m/(.*?)^(?=\s{0,4}[0-9A-Z]+\.)/msg) {
-      $section_text = $1;
-    } else {
-      print STDERR "No section text, end of file marker found.\n";
-      last;
-    }
-
-    if ($section_text =~ m/(.*?)$/msg) {
-      $section_title = $1 if length $1;
-      $section_title =~ s/^\s+//;
-      $section_title =~ s/\s+$//;
-    }
-
-    print STDERR "$this_section [$section_title]\n" if $debug >= 2;
-    $sections{$this_section}{title} = $section_title;
-
-    print STDERR "section text: [$section_text]\n" if $debug >= 2;
-
-    if (not $section_text =~ m/^(?=\d+\s)/msg) {
-      $sections{$this_section}{text} = $section_text;
-    } else {
-      my $last_p = 0;
-      my $p = 0;
-      while ($section_text =~ m/^(\d+)\s(.*?)^(?=\d)/msgc or $section_text =~ m/^(\d+)\s(.*)/msg) {
-        $last_p = $p;
-        $p = $1;
-        my $t = $2;
-
-        print STDERR "paragraph $p: [$t]\n" if $debug >= 3;
-
-        if (($last_p - $p) != -1) {
-          die "Paragraph diff invalid";
+        if ($section_number > 0 and $diff < 0 or $diff > 1) {
+            print STDERR "Diff out of bounds: $diff\n";
+            last;
         }
 
-        while ($t =~ m/^(\s*)(\d+)\)(\s*)(.*?)$/msg) {
-          my $leading_spaces = $1;
-          $footnote = $2;
-          my $middle_spaces = $3;
-          my $footnote_text = "$4\n";
-          print STDERR "1st footnote\n" if $debug;
-          print STDERR "processing footnote $footnote [last: $last_footnote]\n" if $debug >= 2;
-          if ($last_footnote - $footnote != -1) {
-            print STDERR "footnotes dump: \n" if $debug > 5;
-            shift @footnotes;
-            my $dump = Dumper(@footnotes) if $debug > 5;
-            #print STDERR "$dump\n";
-            die "Footnote diff invalid";
-          }
-          $last_footnote = $footnote;
+        my $section_text;
 
-          my $indent = (length $leading_spaces) + (length $footnote) + (length ')') + (length $middle_spaces);
-          $indent--;
-
-          print STDERR "footnote $footnote text [indent=$indent]: [$footnote_text]\n" if $debug >= 4;
-
-          while ($t =~ m/^(.*?)$/msgc) {
-            my $line = $1;
-            print STDERR "processing [$line]\n" if $debug;
-
-            if ($line =~ m/^(\s*)(\d+)\)(\s*)(.*?)$/msg) {
-              print STDERR "----------------\n" if $debug >= 1;
-              print STDERR "footnote $footnote: [$footnote_text]\n" if $debug >= 1;
-              $footnotes[$footnote] = $footnote_text;
-              print STDERR "----------------\n" if $debug >= 1;
-
-              $leading_spaces = $1;
-              $footnote = $2;
-              $middle_spaces = $3;
-              $footnote_text = "$4\n";
-
-              print STDERR "2nd footnote\n" if $debug >= 2;
-              print STDERR "processing footnote $footnote [last: $last_footnote]\n" if $debug >= 2;
-              if ($last_footnote - $footnote != -1) {
-                print STDERR "footnotes dump: \n";
-                shift @footnotes;
-                my $dump = Dumper(@footnotes);
-                print STDERR "$dump\n" if $debug >= 3;
-                die "Footnote diff invalid";
-              }
-              $last_footnote = $footnote;
-
-              my $indent = (length $leading_spaces) + (length $footnote) + (length ')') + (length $middle_spaces);
-              $indent--;
-
-              print STDERR "footnote $footnote text [indent=$indent]: [$footnote_text]\n" if $debug >= 4;
-              next;
-            }
-
-            if (not $line =~ m/^\s{$indent}/msg) {
-              print STDERR "INTERRUPTED FOOTNOTE\n";
-              last;
-            }
-            $footnote_text .= "$line\n";
-            print STDERR "footnote $footnote text: appending [$line]\n" if $debug >= 3;
-          }
-
-          print STDERR "----------------\n" if $debug >= 1;
-          print STDERR "footnote $footnote: [$footnote_text]\n" if $debug >= 1;
-          $footnotes[$footnote] = $footnote_text;
-          print STDERR "----------------\n" if $debug >= 1;
+        if ($text =~ m/(.*?)^(?=\s{0,4}[0-9A-Z]+\.)/msg) { $section_text = $1; }
+        else {
+            print STDERR "No section text, end of file marker found.\n";
+            last;
         }
 
-        $sections{$this_section . "p$p"}{text} = "$p $t";
-      }
+        if ($section_text =~ m/(.*?)$/msg) {
+            $section_title = $1 if length $1;
+            $section_title =~ s/^\s+//;
+            $section_title =~ s/\s+$//;
+        }
+
+        print STDERR "$this_section [$section_title]\n" if $debug >= 2;
+        $sections{$this_section}{title} = $section_title;
+
+        print STDERR "section text: [$section_text]\n" if $debug >= 2;
+
+        if (not $section_text =~ m/^(?=\d+\s)/msg) { $sections{$this_section}{text} = $section_text; }
+        else {
+            my $last_p = 0;
+            my $p      = 0;
+            while ($section_text =~ m/^(\d+)\s(.*?)^(?=\d)/msgc or $section_text =~ m/^(\d+)\s(.*)/msg) {
+                $last_p = $p;
+                $p      = $1;
+                my $t = $2;
+
+                print STDERR "paragraph $p: [$t]\n" if $debug >= 3;
+
+                if (($last_p - $p) != -1) { die "Paragraph diff invalid"; }
+
+                while ($t =~ m/^(\s*)(\d+)\)(\s*)(.*?)$/msg) {
+                    my $leading_spaces = $1;
+                    $footnote = $2;
+                    my $middle_spaces = $3;
+                    my $footnote_text = "$4\n";
+                    print STDERR "1st footnote\n"                                         if $debug;
+                    print STDERR "processing footnote $footnote [last: $last_footnote]\n" if $debug >= 2;
+                    if ($last_footnote - $footnote != -1) {
+                        print STDERR "footnotes dump: \n" if $debug > 5;
+                        shift @footnotes;
+                        my $dump = Dumper(@footnotes) if $debug > 5;
+
+                        #print STDERR "$dump\n";
+                        die "Footnote diff invalid";
+                    }
+                    $last_footnote = $footnote;
+
+                    my $indent = (length $leading_spaces) + (length $footnote) + (length ')') + (length $middle_spaces);
+                    $indent--;
+
+                    print STDERR "footnote $footnote text [indent=$indent]: [$footnote_text]\n" if $debug >= 4;
+
+                    while ($t =~ m/^(.*?)$/msgc) {
+                        my $line = $1;
+                        print STDERR "processing [$line]\n" if $debug;
+
+                        if ($line =~ m/^(\s*)(\d+)\)(\s*)(.*?)$/msg) {
+                            print STDERR "----------------\n"                     if $debug >= 1;
+                            print STDERR "footnote $footnote: [$footnote_text]\n" if $debug >= 1;
+                            $footnotes[$footnote] = $footnote_text;
+                            print STDERR "----------------\n" if $debug >= 1;
+
+                            $leading_spaces = $1;
+                            $footnote       = $2;
+                            $middle_spaces  = $3;
+                            $footnote_text  = "$4\n";
+
+                            print STDERR "2nd footnote\n"                                         if $debug >= 2;
+                            print STDERR "processing footnote $footnote [last: $last_footnote]\n" if $debug >= 2;
+                            if ($last_footnote - $footnote != -1) {
+                                print STDERR "footnotes dump: \n";
+                                shift @footnotes;
+                                my $dump = Dumper(@footnotes);
+                                print STDERR "$dump\n" if $debug >= 3;
+                                die "Footnote diff invalid";
+                            }
+                            $last_footnote = $footnote;
+
+                            my $indent = (length $leading_spaces) + (length $footnote) + (length ')') + (length $middle_spaces);
+                            $indent--;
+
+                            print STDERR "footnote $footnote text [indent=$indent]: [$footnote_text]\n" if $debug >= 4;
+                            next;
+                        }
+
+                        if (not $line =~ m/^\s{$indent}/msg) {
+                            print STDERR "INTERRUPTED FOOTNOTE\n";
+                            last;
+                        }
+                        $footnote_text .= "$line\n";
+                        print STDERR "footnote $footnote text: appending [$line]\n" if $debug >= 3;
+                    }
+
+                    print STDERR "----------------\n"                     if $debug >= 1;
+                    print STDERR "footnote $footnote: [$footnote_text]\n" if $debug >= 1;
+                    $footnotes[$footnote] = $footnote_text;
+                    print STDERR "----------------\n" if $debug >= 1;
+                }
+
+                $sections{$this_section . "p$p"}{text} = "$p $t";
+            }
+        }
     }
-  }
 }
 
 sub bysection {
-  my $inverse = 1;
-  print STDERR "section cmp $a <=> $b\n" if $debug > 10;
+    my $inverse = 1;
+    print STDERR "section cmp $a <=> $b\n" if $debug > 10;
 
-  my ($a1, $p1) = split /p/, $a;
-  my ($b1, $p2) = split /p/, $b;
+    my ($a1, $p1) = split /p/, $a;
+    my ($b1, $p2) = split /p/, $b;
 
-  $p1 = 0 if not defined $p1;
-  $p2 = 0 if not defined $p2;
+    $p1 = 0 if not defined $p1;
+    $p2 = 0 if not defined $p2;
 
-  my @k1 = split /\./, $a1;
-  my @k2 = split /\./, $b1;
-  my @r;
+    my @k1 = split /\./, $a1;
+    my @k2 = split /\./, $b1;
+    my @r;
 
-  if ($#k2 > $#k1) {
-    my @t = @k1;
-    @k1 = @k2;
-    @k2 = @t;
-    my $tp = $p1;
-    $p1 = $p2;
-    $p2 = $tp;
-    $inverse = -1;
-  } else {
-    $inverse = 1;
-  }
+    if ($#k2 > $#k1) {
+        my @t = @k1;
+        @k1 = @k2;
+        @k2 = @t;
+        my $tp = $p1;
+        $p1      = $p2;
+        $p2      = $tp;
+        $inverse = -1;
+    } else {
+        $inverse = 1;
+    }
 
 =cut
   print STDERR "k1 vals:\n";
@@ -209,171 +207,165 @@ sub bysection {
   print STDERR "p2: $p2\n";
 =cut
 
-  my $i = 0;
-  for(; $i < $#k1 + 1; $i++) {
-    if (not defined $k2[$i]) {
-      $r[$i] = 1;
-    } else {
-      print STDERR "   cmp k1[$i] ($k1[$i]) vs k2[$i] ($k2[$i])\n" if $debug >= 5;
-      if ($i == 0) {
-        $r[$i] = $k1[$i] cmp $k2[$i];
-      } else {
-        $r[$i] = $k1[$i] <=> $k2[$i];
-      }
+    my $i = 0;
+    for (; $i < $#k1 + 1; $i++) {
+        if (not defined $k2[$i]) { $r[$i] = 1; }
+        else {
+            print STDERR "   cmp k1[$i] ($k1[$i]) vs k2[$i] ($k2[$i])\n" if $debug >= 5;
+            if   ($i == 0) { $r[$i] = $k1[$i] cmp $k2[$i]; }
+            else           { $r[$i] = $k1[$i] <=> $k2[$i]; }
+        }
+        print STDERR "  r[$i] = $r[$i]\n" if $debug >= 5;
     }
-    print STDERR "  r[$i] = $r[$i]\n" if $debug >= 5;
-  }
 
-  $r[$i] = ($p1 <=> $p2);
-  print STDERR "  $p1 <=> $p2 => r[$i] = $r[$i]\n" if $debug >= 5;
+    $r[$i] = ($p1 <=> $p2);
+    print STDERR "  $p1 <=> $p2 => r[$i] = $r[$i]\n" if $debug >= 5;
 
-  my $ret = 0;
-  foreach my $rv (@r) {
-    print STDERR "  checking r: $rv\n" if $debug >= 5;
-    if ($rv != 0) {
-      $ret = $rv;
-      last;
+    my $ret = 0;
+    foreach my $rv (@r) {
+        print STDERR "  checking r: $rv\n" if $debug >= 5;
+        if ($rv != 0) {
+            $ret = $rv;
+            last;
+        }
     }
-  }
 
-  $ret = $ret * $inverse;
+    $ret = $ret * $inverse;
 
-  print STDERR "ret $ret\n" if $debug >= 5;
-  return $ret;
+    print STDERR "ret $ret\n" if $debug >= 5;
+    return $ret;
 }
 
 sub gen_txt {
-  my $footer = "";
-  my $paren = 0;
-  my $section_head;
-  my $section_title;
+    my $footer = "";
+    my $paren  = 0;
+    my $section_head;
+    my $section_title;
 
-  foreach my $this_section (sort bysection keys %sections) {
-    print STDERR "writing section $this_section\n" if $debug;
-    if (not $this_section =~ m/p/) {
-      print "    $this_section $sections{$this_section}{title}\n";
-      $section_head = $this_section;
-      $section_title = $sections{$this_section}{title};
-    }
-
-    my $section_text = $sections{$this_section}{text};
-
-    for($footnote = 1; $footnote < $#footnotes; $footnote++) {
-      my $sub = quotemeta $footnotes[$footnote];
-      $sub =~ s/(\\ )+/\\s*/g;
-      #print STDERR "subbing out [$footnote) $sub]\n";
-      $section_text =~ s/^\s*$footnote\)\s*$sub//ms;
-    }
-
-    while ($section_text =~ m/^(.*?)$/msg) {
-      my $line = $1;
-
-      print STDERR "paren reset, line [$line]\n" if $debug >= 8;
-      my $number = "";
-      while ($line =~ m/(.)/g) {
-        my $c = $1;
-
-        if ($c =~ m/[0-9]/) {
-          $number .= $c;
-        } elsif ($c eq ' ') {
-          $number = "";
-        } elsif ($c eq '(') {
-          $paren++;
-          print STDERR "got $paren (\n" if $debug >= 8;
-        } elsif ($c eq ')') {
-          $paren--;
-          print STDERR "got $paren )\n" if $debug >= 8;
-
-          if ($paren == -1) {
-            if (length $number and defined $footnotes[$number]) {
-              print STDERR "Got footnote $number here!\n" if $debug;
-              $footer .= "    FOOTNOTE.$number\n      $footnotes[$number]\n";
-            }
-
-            $paren = 0;
-          }
-        } else {
-          $number = "";
+    foreach my $this_section (sort bysection keys %sections) {
+        print STDERR "writing section $this_section\n" if $debug;
+        if (not $this_section =~ m/p/) {
+            print "    $this_section $sections{$this_section}{title}\n";
+            $section_head  = $this_section;
+            $section_title = $sections{$this_section}{title};
         }
-      }
-    }
 
-    print "$section_text\n";
+        my $section_text = $sections{$this_section}{text};
 
-    if (length $footer) {
-      print $footer;
-      $footer = "";
+        for ($footnote = 1; $footnote < $#footnotes; $footnote++) {
+            my $sub = quotemeta $footnotes[$footnote];
+            $sub =~ s/(\\ )+/\\s*/g;
+
+            #print STDERR "subbing out [$footnote) $sub]\n";
+            $section_text =~ s/^\s*$footnote\)\s*$sub//ms;
+        }
+
+        while ($section_text =~ m/^(.*?)$/msg) {
+            my $line = $1;
+
+            print STDERR "paren reset, line [$line]\n" if $debug >= 8;
+            my $number = "";
+            while ($line =~ m/(.)/g) {
+                my $c = $1;
+
+                if    ($c =~ m/[0-9]/) { $number .= $c; }
+                elsif ($c eq ' ')      { $number = ""; }
+                elsif ($c eq '(') {
+                    $paren++;
+                    print STDERR "got $paren (\n" if $debug >= 8;
+                } elsif ($c eq ')') {
+                    $paren--;
+                    print STDERR "got $paren )\n" if $debug >= 8;
+
+                    if ($paren == -1) {
+                        if (length $number and defined $footnotes[$number]) {
+                            print STDERR "Got footnote $number here!\n" if $debug;
+                            $footer .= "    FOOTNOTE.$number\n      $footnotes[$number]\n";
+                        }
+
+                        $paren = 0;
+                    }
+                } else {
+                    $number = "";
+                }
+            }
+        }
+
+        print "$section_text\n";
+
+        if (length $footer) {
+            print $footer;
+            $footer = "";
+        }
     }
-  }
 }
 
 sub gen_html {
-  print "\n\n";
+    print "\n\n";
 
-  my $footer = "";
-  my $paren = 0;
+    my $footer = "";
+    my $paren  = 0;
 
-  foreach my $this_section (sort bysection keys %sections) {
-    print STDERR "writing section $this_section\n" if $debug;
-    print "\n";
-    print "
    \n
    ", encode_entities $this_section, " [", encode_entities $sections{$this_section}{title}, "]
    \n" if not $this_section =~ m/p/;
+    foreach my $this_section (sort bysection keys %sections) {
+        print STDERR "writing section $this_section\n" if $debug;
+        print "    \n";
+        print "
    \n
    ", encode_entities $this_section, " [", encode_entities $sections{$this_section}{title}, "]
    \n" if not $this_section =~ m/p/;
 
-    my $section_text = $sections{$this_section}{text};
+        my $section_text = $sections{$this_section}{text};
 
-    for($footnote = 1; $footnote < $#footnotes; $footnote++) {
-      my $sub = quotemeta $footnotes[$footnote];
-      $sub =~ s/(\\ )+/\\s*/g;
-      #print STDERR "subbing out [$footnote) $sub]\n";
-      $section_text =~ s/^\s*$footnote\)\s*$sub//ms;
-    }
+        for ($footnote = 1; $footnote < $#footnotes; $footnote++) {
+            my $sub = quotemeta $footnotes[$footnote];
+            $sub =~ s/(\\ )+/\\s*/g;
 
-    $section_text = encode_entities $section_text;
-
-    while ($section_text =~ m/^(.*?)$/msg) {
-      my $line = $1;
-
-      print STDERR "paren reset, line [$line]\n" if $debug >= 8;
-      my $number = "";
-      while ($line =~ m/(.)/g) {
-        my $c = $1;
-
-        if ($c =~ m/[0-9]/) {
-          $number .= $c;
-        } elsif ($c eq ' ') {
-          $number = "";
-        } elsif ($c eq '(') {
-          $paren++;
-          print STDERR "got $paren (\n" if $debug >= 8;
-        } elsif ($c eq ')') {
-          $paren--;
-          print STDERR "got $paren )\n" if $debug >= 8;
-
-          if ($paren == -1) {
-            if (length $number and defined $footnotes[$number]) {
-              print STDERR "Got footnote $number here!\n" if $debug;
-              $section_text =~ s/$number\)/[$number]<\/sup>/;
-              $footer .= "    \n
    Footnote $number) ", encode_entities $footnotes[$number], "
    \n    \n";
-            }
-
-            $paren = 0;
-          }
-        } else {
-          $number = "";
+            #print STDERR "subbing out [$footnote) $sub]\n";
+            $section_text =~ s/^\s*$footnote\)\s*$sub//ms;
+        }
+
+        $section_text = encode_entities $section_text;
+
+        while ($section_text =~ m/^(.*?)$/msg) {
+            my $line = $1;
+
+            print STDERR "paren reset, line [$line]\n" if $debug >= 8;
+            my $number = "";
+            while ($line =~ m/(.)/g) {
+                my $c = $1;
+
+                if    ($c =~ m/[0-9]/) { $number .= $c; }
+                elsif ($c eq ' ')      { $number = ""; }
+                elsif ($c eq '(') {
+                    $paren++;
+                    print STDERR "got $paren (\n" if $debug >= 8;
+                } elsif ($c eq ')') {
+                    $paren--;
+                    print STDERR "got $paren )\n" if $debug >= 8;
+
+                    if ($paren == -1) {
+                        if (length $number and defined $footnotes[$number]) {
+                            print STDERR "Got footnote $number here!\n" if $debug;
+                            $section_text =~ s/$number\)/[$number]<\/sup>/;
+                            $footer .= "\n
    Footnote $number) ", encode_entities $footnotes[$number], "
    \n    \n";
+                        }
+
+                        $paren = 0;
+                    }
+                } else {
+                    $number = "";
+                }
+            }
+        }
+
+        $section_text =~ s/\(([0-9.]+)\)/($1<\/a>)/g;
+        $footer       =~ s/\(([0-9.]+)\)/($1<\/a>)/g;
+
+        print "
    ", $section_text, "
    \n";
+        print "    \n";
+
+        if (length $footer) {
+            print $footer;
+            $footer = "";
         }
-      }
     }
 
-    $section_text =~ s/\(([0-9.]+)\)/($1<\/a>)/g;
-    $footer =~ s/\(([0-9.]+)\)/($1<\/a>)/g;
-
-    print "
    ", $section_text, "
    \n";
-    print "    \n";
-
-    if (length $footer) {
-      print $footer;
-      $footer = "";
-    }
-  }
-
-  print "\n\n\n";
+    print "\n\n\n";
 }
diff --git a/modules/get_title.pl b/modules/get_title.pl
index 0282397e..2c20a4bd 100755
--- a/modules/get_title.pl
+++ b/modules/get_title.pl
@@ -11,13 +11,12 @@ use HTML::Entities;
 use Text::Levenshtein qw(fastdistance);
 use Time::HiRes qw(gettimeofday);
 
-if ($#ARGV <= 0)
-{
-  print "Usage: title nick URL\n";
-  exit;
+if ($#ARGV <= 0) {
+    print "Usage: title nick URL\n";
+    exit;
 }
 
-my $nick = shift(@ARGV);
+my $nick      = shift(@ARGV);
 my $arguments = join("%20", @ARGV);
 
 $arguments =~ s/\W$//;
@@ -89,27 +88,26 @@ $ua->max_size(200 * 1024);
 
 my $response = $ua->get("$arguments");
 
-if (not $response->is_success)
-{
-  #print "Couldn't get link.\n";
-  use Data::Dumper;
-  print STDERR Dumper $response;
-  die "Couldn't get link: $arguments";
+if (not $response->is_success) {
+
+    #print "Couldn't get link.\n";
+    use Data::Dumper;
+    print STDERR Dumper $response;
+    die "Couldn't get link: $arguments";
 }
 
 my $text = $response->decoded_content;
 
-if ($text =~ m/(.*?)<\/title>/msi)
-{
-  $t = $1;
-} else {
-  #print "No title for link.\n";
-  exit;
+if ($text =~ m/<title>(.*?)<\/title>/msi) { $t = $1; }
+else {
+
+    #print "No title for link.\n";
+    exit;
 }
 
-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/\s+/ /g;
 $t =~ s/^\s+//g;
@@ -135,8 +133,8 @@ $t =~ s/<em>//g;
 $t =~ s/<\/em>//g;
 
 if (length $t > 150) {
-  $t = substr($t, 0, 150);
-  $t = "$t [...]";
+    $t = substr($t, 0, 150);
+    $t = "$t [...]";
 }
 
 # $nick =~ s/^(.)(.*)/$1|$2/;
@@ -150,13 +148,11 @@ my ($file) = $arguments =~ m/.*\/(.*)$/;
 $file =~ s/[_-]/ /g;
 
 my $distance = fastdistance(lc $file, lc $t);
-my $length = (length $file > length $t) ? length $file : length $t;
+my $length   = (length $file > length $t) ? length $file : length $t;
 
-if ($distance / $length < 0.75) {
-    exit;
-}
+if ($distance / $length < 0.75) { exit; }
 
-exit if $t !~ m/\s/; # exit if title is only one word -- this isn't usually interesting
+exit if $t !~ m/\s/;                                 # exit if title is only one word -- this isn't usually interesting
 exit if $t =~ m{christel}i;
 exit if $t =~ m{streamable}i;
 exit if $t =~ m{freenode}i;
@@ -182,11 +178,11 @@ exit if $t =~ m/(?:sign up|login)/i;
 
 my @data;
 if (open my $fh, "<", "last-title-$nick.dat") {
-  @data = <$fh>;
-  close $fh;
+    @data = <$fh>;
+    close $fh;
 
-  chomp $data[0];
-  exit if $t eq $data[0] and scalar gettimeofday - $data[1] < 1800;
+    chomp $data[0];
+    exit if $t eq $data[0] and scalar gettimeofday - $data[1] < 1800;
 }
 
 open my $fh, ">", "last-title-$nick.dat";
diff --git a/modules/getcfact.pl b/modules/getcfact.pl
index 34209dfc..12be065f 100755
--- a/modules/getcfact.pl
+++ b/modules/getcfact.pl
@@ -7,19 +7,19 @@
 use warnings;
 use strict;
 
-my $CFACTS = 'cfacts.txt';
+my $CFACTS         = 'cfacts.txt';
 my $CJEOPARDY_DATA = 'cjeopardy.dat';
 
 my $text = join(' ', @ARGV);
 
 sub encode { my $str = shift; $str =~ s/\\(.)/{sprintf "\\%03d", ord($1)}/ge; return $str; }
-sub decode { my $str = shift; $str =~ s/\\(\d{3})/{"\\" . chr($1)}/ge; return $str }
+sub decode { my $str = shift; $str =~ s/\\(\d{3})/{"\\" . chr($1)}/ge;        return $str }
 
 my $jeopardy_answers;
 open my $fh, "<", $CJEOPARDY_DATA;
 if (defined $fh) {
-  $jeopardy_answers = <$fh>;
-  close $fh;
+    $jeopardy_answers = <$fh>;
+    close $fh;
 }
 
 my @valid_answers = map { lc decode $_ } split /\|/, encode $jeopardy_answers;
@@ -27,14 +27,11 @@ my @valid_answers = map { lc decode $_ } split /\|/, encode $jeopardy_answers;
 my @facts;
 open $fh, "<", $CFACTS or die "Could not open $CFACTS: $!";
 while (my $fact = <$fh>) {
-  next if length $text and $fact !~ /\Q$text\E/i;
-  next if grep { $fact =~ /\Q$_\E/i } @valid_answers;
-  push @facts, $fact;
+    next if length $text and $fact !~ /\Q$text\E/i;
+    next if grep { $fact =~ /\Q$_\E/i } @valid_answers;
+    push @facts, $fact;
 }
 close $fh;
 
-if (not @facts) {
-  print "No fact containing text $text found.\n";
-} else {
-  print $facts[int rand(@facts)], "\n";
-}
+if   (not @facts) { print "No fact containing text $text found.\n"; }
+else              { print $facts[int rand(@facts)], "\n"; }
diff --git a/modules/headlines.pl b/modules/headlines.pl
index 2e8d10b9..ffc7d469 100755
--- a/modules/headlines.pl
+++ b/modules/headlines.pl
@@ -12,106 +12,104 @@ use LWP::Simple;
 # similiar URLS (try Google?) may be useful.
 
 my %news_sites = (
-  "jbad"       => [ "http://jalalabad.us/backend/geeklog.rdf",
-                    "Jalalabad.us"
-                  ],
-  "bbc"        => [ "http://news.bbc.co.uk/rss/newsonline_uk_edition/world/rss091.xml",
-		    "news.bbc.co.uk"
-                  ],
-  "cnn"        => [ "http://www.cnn.com/cnn.rss",
-                    "CNN News"
-                  ],
-  "chealth"    => [ "http://www.cnn.com/health/health.rdf",
-                    "CNN Health"
-                  ],
-  "ctech"      => [ "http://www.cnn.com/technology/tech.rdf",
-                    "CNN Technology"
-                  ],
-  "csports"    => [ "http://www.cnn.com/sports/sports.rdf",
-                    "CNN Sports"
-                  ],
-  "/."         => [ "http://slashdot.org/slashdot.rdf",
-                    "Slashdot"
-                  ],
-  "nyttech"    => [ "http://xml.newsisfree.com/feeds/62/162.xml",
-                    "New York Times Technology"
-                  ],
-  "morons"     => [ "http://www.morons.org/morons.rss",
-                    "morons.org"
-                  ]
+    "jbad" => [
+        "http://jalalabad.us/backend/geeklog.rdf",
+        "Jalalabad.us"
+    ],
+    "bbc" => [
+        "http://news.bbc.co.uk/rss/newsonline_uk_edition/world/rss091.xml",
+        "news.bbc.co.uk"
+    ],
+    "cnn" => [
+        "http://www.cnn.com/cnn.rss",
+        "CNN News"
+    ],
+    "chealth" => [
+        "http://www.cnn.com/health/health.rdf",
+        "CNN Health"
+    ],
+    "ctech" => [
+        "http://www.cnn.com/technology/tech.rdf",
+        "CNN Technology"
+    ],
+    "csports" => [
+        "http://www.cnn.com/sports/sports.rdf",
+        "CNN Sports"
+    ],
+    "/." => [
+        "http://slashdot.org/slashdot.rdf",
+        "Slashdot"
+    ],
+    "nyttech" => [
+        "http://xml.newsisfree.com/feeds/62/162.xml",
+        "New York Times Technology"
+    ],
+    "morons" => [
+        "http://www.morons.org/morons.rss",
+        "morons.org"
+    ]
 );
 
-my $args = join(' ', @ARGV);
+my $args  = join(' ', @ARGV);
 my $links = 0;
 my $key;
 my $value;
 
-
 if ($args =~ /^links\s+(.*)/i) {
-  $args = $1;
-  $links = 1;
+    $args  = $1;
+    $links = 1;
 }
 
 $args = quotemeta($args);
 
 foreach $key (keys %news_sites) {
-  $value = $news_sites{$key}->[0];
+    $value = $news_sites{$key}->[0];
 
-  if ($key =~ /$args/i) {
-    check_news($value, $links, $news_sites{$key}->[1]);
-    exit(0);
-  }
+    if ($key =~ /$args/i) {
+        check_news($value, $links, $news_sites{$key}->[1]);
+        exit(0);
+    }
 }
 
 print "Invalid Headline.  Usage:  .headlines [links] <news server> - News servers are: ";
 
-foreach $key (keys %news_sites) {
-  print "$key => $news_sites{$key}->[1], ";
-}
+foreach $key (keys %news_sites) { print "$key => $news_sites{$key}->[1], "; }
 
 print "\n";
 
-
-
 sub check_news {
-  my ($site, $links, $headline) = @_;
-  my $text = "$headline: ";
+    my ($site, $links, $headline) = @_;
+    my $text = "$headline: ";
 
-  my $rss = new XML::RSS;
+    my $rss = new XML::RSS;
 
-  my $content = get($site);
+    my $content = get($site);
 
-  if ($content) {
-    eval {
-      $rss->parse($content);
-    };
-    if (my $error = $@) {
-       $error =~ s/\n//g;
-       print "Got error: $error\n";
-       return 0;
-     }
+    if ($content) {
+        eval { $rss->parse($content); };
+        if (my $error = $@) {
+            $error =~ s/\n//g;
+            print "Got error: $error\n";
+            return 0;
+        }
 
+        foreach my $item (@{$rss->{'items'}}) {
+            next unless defined($item->{'title'}) && defined($item->{'link'});
 
-    foreach my $item (@{$rss->{'items'}}) {
-      next unless defined($item->{'title'}) && defined($item->{'link'});
-
-      if ($links == 1)
-      {
-        $text = " $item->{'title'} : ( $item->{'link'} )";
-        $text =~ s/\n//g;
-        $text =~ s/\t//g;
-        $text =~ s/\r//g;
-        print "$text\n";
-      }
-      else
-      {
-        $text .= " $item->{'title'} -";
-      }
+            if ($links == 1) {
+                $text = " $item->{'title'} : ( $item->{'link'} )";
+                $text =~ s/\n//g;
+                $text =~ s/\t//g;
+                $text =~ s/\r//g;
+                print "$text\n";
+            } else {
+                $text .= " $item->{'title'} -";
+            }
+        }
     }
-  }
-  $text =~ s/\n//g;
-  $text =~ s/\t//g;
-  $text =~ s/\r//g;
-  print "$text\n" if ($links == 0);
+    $text =~ s/\n//g;
+    $text =~ s/\t//g;
+    $text =~ s/\r//g;
+    print "$text\n" if ($links == 0);
 }
 
diff --git a/modules/ideone.pl b/modules/ideone.pl
index daf6ffa6..0cca8ed6 100755
--- a/modules/ideone.pl
+++ b/modules/ideone.pl
@@ -10,6 +10,7 @@ use feature qw(switch);
 
 use SOAP::Lite;
 $SOAP::Constants::DO_NOT_USE_XML_PARSER = 1;
+
 use IPC::Open2;
 use HTML::Entities;
 use Text::Balanced qw(extract_codeblock extract_delimited);
@@ -21,70 +22,70 @@ my $result;
 
 my $MAX_UNDO_HISTORY = 100;
 
-my $output = "";
+my $output   = "";
 my $nooutput = 'No output.';
 
 my %languages = (
-  'Ada'                          => { 'id' =>    '7', 'name' => 'Ada (gnat-4.3.2)'                                 },
-  'asm'                          => { 'id' =>   '13', 'name' => 'Assembler (nasm-2.07)'                            },
-  'nasm'                         => { 'id' =>   '13', 'name' => 'Assembler (nasm-2.07)'                            },
-  'gas'                          => { 'id' =>   '45', 'name' => 'Assembler (gcc-4.3.4)'                            },
-  'Assembler'                    => { 'id' =>   '13', 'name' => 'Assembler (nasm-2.07)'                            },
-  'Assembler'                    => { 'id' =>   '13', 'name' => 'Assembler (nasm-2.07)'                            },
-  'gawk'                         => { 'id' =>  '104', 'name' => 'AWK (gawk) (gawk-3.1.6)'                          },
-  'mawk'                         => { 'id' =>  '105', 'name' => 'AWK (mawk) (mawk-1.3.3)'                          },
-  'Bash'                         => { 'id' =>   '28', 'name' => 'Bash (bash 4.0.35)'                               },
-  'bc'                           => { 'id' =>  '110', 'name' => 'bc (bc-1.06.95)'                                  },
-  'Brainfuck'                    => { 'id' =>   '12', 'name' => 'Brainf**k (bff-1.0.3.1)'                          },
-  'bf'                           => { 'id' =>   '12', 'name' => 'Brainf**k (bff-1.0.3.1)'                          },
-  'gnu89'                        => { 'id' =>   '11', 'name' => 'C (gcc-4.3.4)'                                    },
-  'C89'                          => { 'id' =>   '11', 'name' => 'C (gcc-4.3.4)'                                    },
-  'C'                            => { 'id' =>   '11', 'name' => 'C (gcc-4.3.4)'                                    },
-  'C#'                           => { 'id' =>   '27', 'name' => 'C# (gmcs 2.0.1)'                                  },
-  'C++'                          => { 'id' =>    '1', 'name' => 'C++ (gcc-4.3.4)'                                  },
-  'C99'                          => { 'id' =>   '34', 'name' => 'C99 strict (gcc-4.3.4)'                           },
-  'CLIPS'                        => { 'id' =>   '14', 'name' => 'CLIPS (clips 6.24)'                               },
-  'Clojure'                      => { 'id' =>  '111', 'name' => 'Clojure (clojure 1.1.0)'                          },
-  'COBOL'                        => { 'id' =>  '118', 'name' => 'COBOL (open-cobol-1.0)'                           },
-  'COBOL85'                      => { 'id' =>  '106', 'name' => 'COBOL 85 (tinycobol-0.65.9)'                      },
-  'clisp'                        => { 'id' =>   '32', 'name' => 'Common Lisp (clisp) (clisp 2.47)'                 },
-  'D'                            => { 'id' =>  '102', 'name' => 'D (dmd) (dmd-2.042)'                              },
-  'Erlang'                       => { 'id' =>   '36', 'name' => 'Erlang (erl-5.7.3)'                               },
-  'Forth'                        => { 'id' =>  '107', 'name' => 'Forth (gforth-0.7.0)'                             },
-  'Fortran'                      => { 'id' =>    '5', 'name' => 'Fortran (gfortran-4.3.4)'                         },
-  'Go'                           => { 'id' =>  '114', 'name' => 'Go (gc 2010-01-13)'                               },
-  'Haskell'                      => { 'id' =>   '21', 'name' => 'Haskell (ghc-6.8.2)'                              },
-  'Icon'                         => { 'id' =>   '16', 'name' => 'Icon (iconc 9.4.3)'                               },
-  'Intercal'                     => { 'id' =>    '9', 'name' => 'Intercal (c-intercal 28.0-r1)'                    },
-  'Java'                         => { 'id' =>   '10', 'name' => 'Java (sun-jdk-1.6.0.17)'                          },
-  'JS'                           => { 'id' =>   '35', 'name' => 'JavaScript (rhino) (rhino-1.6.5)'                 },
-  'JScript'                      => { 'id' =>   '35', 'name' => 'JavaScript (rhino) (rhino-1.6.5)'                 },
-  'JavaScript'                   => { 'id' =>   '35', 'name' => 'JavaScript (rhino) (rhino-1.6.5)'                 },
-  'JavaScript-rhino'             => { 'id' =>   '35', 'name' => 'JavaScript (rhino) (rhino-1.6.5)'                 },
-  'JavaScript-spidermonkey'      => { 'id' =>  '112', 'name' => 'JavaScript (spidermonkey) (spidermonkey-1.7)'     },
-  'Lua'                          => { 'id' =>   '26', 'name' => 'Lua (luac 5.1.4)'                                 },
-  'Nemerle'                      => { 'id' =>   '30', 'name' => 'Nemerle (ncc 0.9.3)'                              },
-  'Nice'                         => { 'id' =>   '25', 'name' => 'Nice (nicec 0.9.6)'                               },
-  'Ocaml'                        => { 'id' =>    '8', 'name' => 'Ocaml (ocamlopt 3.10.2)'                          },
-  'Pascal'                       => { 'id' =>   '22', 'name' => 'Pascal (fpc) (fpc 2.2.0)'                         },
-  'Pascal-fpc'                   => { 'id' =>   '22', 'name' => 'Pascal (fpc) (fpc 2.2.0)'                         },
-  'Pascal-gpc'                   => { 'id' =>    '2', 'name' => 'Pascal (gpc) (gpc 20070904)'                      },
-  'Perl'                         => { 'id' =>    '3', 'name' => 'Perl (perl 5.8.8)'                                },
-  'PHP'                          => { 'id' =>   '29', 'name' => 'PHP (php 5.2.11)'                                 },
-  'Pike'                         => { 'id' =>   '19', 'name' => 'Pike (pike 7.6.86)'                               },
-  'Prolog'                       => { 'id' =>  '108', 'name' => 'Prolog (gnu) (gprolog-1.3.1)'                     },
-  'Prolog-gnu'                   => { 'id' =>  '108', 'name' => 'Prolog (gnu) (gprolog-1.3.1)'                     },
-  'Prolog-swi'                   => { 'id' =>   '15', 'name' => 'Prolog (swi) (swipl 5.6.64)'                      },
-  'Python'                       => { 'id' =>    '4', 'name' => 'Python (python 2.6.4)'                            },
-  'Python3'                      => { 'id' =>  '116', 'name' => 'Python3 (python-3.1.1)'                           },
-  'R'                            => { 'id' =>  '117', 'name' => 'R (R-2.9.2)'                                      },
-  'Ruby'                         => { 'id' =>   '17', 'name' => 'Ruby (ruby 1.8.7)'                                },
-  'Scala'                        => { 'id' =>   '39', 'name' => 'Scala (Scalac 2.7.7)'                             },
-  'Scheme'                       => { 'id' =>   '33', 'name' => 'Scheme (guile) (guile 1.8.5)'                     },
-  'Smalltalk'                    => { 'id' =>   '23', 'name' => 'Smalltalk (gst 3.1)'                              },
-  'Tcl'                          => { 'id' =>   '38', 'name' => 'Tcl (tclsh 8.5.7)'                                },
-  'Unlambda'                     => { 'id' =>  '115', 'name' => 'Unlambda (unlambda-2.0.0)'                        },
-  'VB'                           => { 'id' =>  '101', 'name' => 'Visual Basic .NET (mono-2.4.2.3)'                 },
+    'Ada'                     => {'id' => '7',   'name' => 'Ada (gnat-4.3.2)'},
+    'asm'                     => {'id' => '13',  'name' => 'Assembler (nasm-2.07)'},
+    'nasm'                    => {'id' => '13',  'name' => 'Assembler (nasm-2.07)'},
+    'gas'                     => {'id' => '45',  'name' => 'Assembler (gcc-4.3.4)'},
+    'Assembler'               => {'id' => '13',  'name' => 'Assembler (nasm-2.07)'},
+    'Assembler'               => {'id' => '13',  'name' => 'Assembler (nasm-2.07)'},
+    'gawk'                    => {'id' => '104', 'name' => 'AWK (gawk) (gawk-3.1.6)'},
+    'mawk'                    => {'id' => '105', 'name' => 'AWK (mawk) (mawk-1.3.3)'},
+    'Bash'                    => {'id' => '28',  'name' => 'Bash (bash 4.0.35)'},
+    'bc'                      => {'id' => '110', 'name' => 'bc (bc-1.06.95)'},
+    'Brainfuck'               => {'id' => '12',  'name' => 'Brainf**k (bff-1.0.3.1)'},
+    'bf'                      => {'id' => '12',  'name' => 'Brainf**k (bff-1.0.3.1)'},
+    'gnu89'                   => {'id' => '11',  'name' => 'C (gcc-4.3.4)'},
+    'C89'                     => {'id' => '11',  'name' => 'C (gcc-4.3.4)'},
+    'C'                       => {'id' => '11',  'name' => 'C (gcc-4.3.4)'},
+    'C#'                      => {'id' => '27',  'name' => 'C# (gmcs 2.0.1)'},
+    'C++'                     => {'id' => '1',   'name' => 'C++ (gcc-4.3.4)'},
+    'C99'                     => {'id' => '34',  'name' => 'C99 strict (gcc-4.3.4)'},
+    'CLIPS'                   => {'id' => '14',  'name' => 'CLIPS (clips 6.24)'},
+    'Clojure'                 => {'id' => '111', 'name' => 'Clojure (clojure 1.1.0)'},
+    'COBOL'                   => {'id' => '118', 'name' => 'COBOL (open-cobol-1.0)'},
+    'COBOL85'                 => {'id' => '106', 'name' => 'COBOL 85 (tinycobol-0.65.9)'},
+    'clisp'                   => {'id' => '32',  'name' => 'Common Lisp (clisp) (clisp 2.47)'},
+    'D'                       => {'id' => '102', 'name' => 'D (dmd) (dmd-2.042)'},
+    'Erlang'                  => {'id' => '36',  'name' => 'Erlang (erl-5.7.3)'},
+    'Forth'                   => {'id' => '107', 'name' => 'Forth (gforth-0.7.0)'},
+    'Fortran'                 => {'id' => '5',   'name' => 'Fortran (gfortran-4.3.4)'},
+    'Go'                      => {'id' => '114', 'name' => 'Go (gc 2010-01-13)'},
+    'Haskell'                 => {'id' => '21',  'name' => 'Haskell (ghc-6.8.2)'},
+    'Icon'                    => {'id' => '16',  'name' => 'Icon (iconc 9.4.3)'},
+    'Intercal'                => {'id' => '9',   'name' => 'Intercal (c-intercal 28.0-r1)'},
+    'Java'                    => {'id' => '10',  'name' => 'Java (sun-jdk-1.6.0.17)'},
+    'JS'                      => {'id' => '35',  'name' => 'JavaScript (rhino) (rhino-1.6.5)'},
+    'JScript'                 => {'id' => '35',  'name' => 'JavaScript (rhino) (rhino-1.6.5)'},
+    'JavaScript'              => {'id' => '35',  'name' => 'JavaScript (rhino) (rhino-1.6.5)'},
+    'JavaScript-rhino'        => {'id' => '35',  'name' => 'JavaScript (rhino) (rhino-1.6.5)'},
+    'JavaScript-spidermonkey' => {'id' => '112', 'name' => 'JavaScript (spidermonkey) (spidermonkey-1.7)'},
+    'Lua'                     => {'id' => '26',  'name' => 'Lua (luac 5.1.4)'},
+    'Nemerle'                 => {'id' => '30',  'name' => 'Nemerle (ncc 0.9.3)'},
+    'Nice'                    => {'id' => '25',  'name' => 'Nice (nicec 0.9.6)'},
+    'Ocaml'                   => {'id' => '8',   'name' => 'Ocaml (ocamlopt 3.10.2)'},
+    'Pascal'                  => {'id' => '22',  'name' => 'Pascal (fpc) (fpc 2.2.0)'},
+    'Pascal-fpc'              => {'id' => '22',  'name' => 'Pascal (fpc) (fpc 2.2.0)'},
+    'Pascal-gpc'              => {'id' => '2',   'name' => 'Pascal (gpc) (gpc 20070904)'},
+    'Perl'                    => {'id' => '3',   'name' => 'Perl (perl 5.8.8)'},
+    'PHP'                     => {'id' => '29',  'name' => 'PHP (php 5.2.11)'},
+    'Pike'                    => {'id' => '19',  'name' => 'Pike (pike 7.6.86)'},
+    'Prolog'                  => {'id' => '108', 'name' => 'Prolog (gnu) (gprolog-1.3.1)'},
+    'Prolog-gnu'              => {'id' => '108', 'name' => 'Prolog (gnu) (gprolog-1.3.1)'},
+    'Prolog-swi'              => {'id' => '15',  'name' => 'Prolog (swi) (swipl 5.6.64)'},
+    'Python'                  => {'id' => '4',   'name' => 'Python (python 2.6.4)'},
+    'Python3'                 => {'id' => '116', 'name' => 'Python3 (python-3.1.1)'},
+    'R'                       => {'id' => '117', 'name' => 'R (R-2.9.2)'},
+    'Ruby'                    => {'id' => '17',  'name' => 'Ruby (ruby 1.8.7)'},
+    'Scala'                   => {'id' => '39',  'name' => 'Scala (Scalac 2.7.7)'},
+    'Scheme'                  => {'id' => '33',  'name' => 'Scheme (guile) (guile 1.8.5)'},
+    'Smalltalk'               => {'id' => '23',  'name' => 'Smalltalk (gst 3.1)'},
+    'Tcl'                     => {'id' => '38',  'name' => 'Tcl (tclsh 8.5.7)'},
+    'Unlambda'                => {'id' => '115', 'name' => 'Unlambda (unlambda-2.0.0)'},
+    'VB'                      => {'id' => '101', 'name' => 'Visual Basic .NET (mono-2.4.2.3)'},
 );
 
 # C    11
@@ -92,14 +93,16 @@ my %languages = (
 # C++  1
 
 my %preludes = (
-                 '34'  => "#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",
-                 '11'  => "#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",
-                 '1'   => "#include <iostream>\n#include <cstdio>\n",
-               );
+    '34' =>
+      "#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",
+    '11' =>
+      "#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",
+    '1' => "#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;
@@ -107,426 +110,405 @@ my $code = join ' ', @ARGV;
 my @last_code;
 
 if (open FILE, "< ideone_last_code.txt") {
-  while (my $line = <FILE>) {
-    chomp $line;
-    push @last_code, $line;
-  }
-  close FILE;
+    while (my $line = <FILE>) {
+        chomp $line;
+        push @last_code, $line;
+    }
+    close FILE;
 }
 
 if ($code =~ m/^\s*show\s*$/i) {
-  if (defined $last_code[0]) {
-    print "$nick: $last_code[0]\n";
-  } else {
-    print "$nick: No recent code to show.\n"
-  }
-  exit 0;
+    if   (defined $last_code[0]) { print "$nick: $last_code[0]\n"; }
+    else                         { print "$nick: No recent code to show.\n" }
+    exit 0;
 }
 
 my $got_run;
 
 if ($code =~ m/^\s*run\s*$/i) {
-  if (defined $last_code[0]) {
-    $code = $last_code[0];
-    $got_run = 1;
-  } else {
-    print "$nick: No recent code to run.\n";
-    exit 0;
-  }
-} else {
-  my $subcode = $code;
-  my $got_undo = 0;
-  my $got_sub = 0;
-
-  while ($subcode =~ s/^\s*(and)?\s*undo//) {
-    splice @last_code, 0, 1;
-    if (not defined $last_code[0]) {
-      print "$nick: No more undos remaining.\n";
-      exit 0;
+    if (defined $last_code[0]) {
+        $code    = $last_code[0];
+        $got_run = 1;
     } else {
-      $code = $last_code[0];
-      $got_undo = 1;
+        print "$nick: No recent code to run.\n";
+        exit 0;
     }
-  }
+} else {
+    my $subcode  = $code;
+    my $got_undo = 0;
+    my $got_sub  = 0;
 
-  my @replacements;
-  my $prevchange = $last_code[0];
-  my $got_changes = 0;
-
-  while (1) {
-    $got_sub = 0;
-    $got_changes = 0;
-
-    if ($subcode =~ m/^\s*(and)?\s*remove \s*([^']+)?\s*'/) {
-      my $modifier = 'first';
-
-      $subcode =~ s/^\s*(and)?\s*//;
-      $subcode =~ s/remove\s*([^']+)?\s*//i;
-      $modifier = $1 if defined $1;
-      $modifier =~ s/\s+$//;
-
-      my ($e, $r) = extract_delimited($subcode, "'");
-
-      my $text;
-
-      if (defined $e) {
-        $text = $e;
-        $text =~ s/^'//;
-        $text =~ s/'$//;
-        $subcode = "replace $modifier '$text' with ''$r";
-      } else {
-        print "$nick: Unbalanced single quotes.  Usage: !cc remove [all, first, .., tenth, last] 'text' [and ...]\n";
-        exit 0;
-      }
-      next;
-    }
-
-    if ($subcode =~ s/^\s*(and)?\s*add '//) {
-      $subcode = "'$subcode";
-
-      my ($e, $r) = extract_delimited($subcode, "'");
-
-      my $text;
-
-      if (defined $e) {
-        $text = $e;
-        $text =~ s/^'//;
-        $text =~ s/'$//;
-        $subcode = $r;
-
-        $got_sub = 1;
-        $got_changes = 1;
-
-        if (not defined $prevchange) {
-          print "$nick: No recent code to append to.\n";
-          exit 0;
-        }
-
-        $code = $prevchange;
-        $code =~ s/$/ $text/;
-        $prevchange = $code;
-      } else {
-        print "$nick: Unbalanced single quotes.  Usage: !cc add 'text' [and ...]\n";
-        exit 0;
-      }
-      next;
-    }
-
-    if ($subcode =~ m/^\s*(and)?\s*replace\s*([^']+)?\s*'.*'\s*with\s*'.*'/i) {
-      $got_sub = 1;
-      my $modifier = 'first';
-
-      $subcode =~ s/^\s*(and)?\s*//;
-      $subcode =~ s/replace\s*([^']+)?\s*//i;
-      $modifier = $1 if defined $1;
-      $modifier =~ s/\s+$//;
-
-      my ($from, $to);
-      my ($e, $r) = extract_delimited($subcode, "'");
-
-      if (defined $e) {
-        $from = $e;
-        $from =~ s/^'//;
-        $from =~ s/'$//;
-        $from = quotemeta $from;
-        $subcode = $r;
-        $subcode =~ s/\s*with\s*//i;
-      } else {
-        print "$nick: Unbalanced single quotes.  Usage: !cc replace 'from' with 'to' [and ...]\n";
-        exit 0;
-      }
-
-      ($e, $r) = extract_delimited($subcode, "'");
-
-      if (defined $e) {
-        $to = $e;
-        $to =~ s/^'//;
-        $to =~ s/'$//;
-        $subcode = $r;
-      } else {
-        print "$nick: Unbalanced single quotes.  Usage: !cc replace 'from' with 'to' [and replace ... with ... [and ...]]\n";
-        exit 0;
-      }
-
-      given($modifier) {
-        when($_ eq 'all'    ) {}
-        when($_ eq 'last'   ) {}
-        when($_ eq 'first'  ) { $modifier = 1; }
-        when($_ eq 'second' ) { $modifier = 2; }
-        when($_ eq 'third'  ) { $modifier = 3; }
-        when($_ eq 'fourth' ) { $modifier = 4; }
-        when($_ eq 'fifth'  ) { $modifier = 5; }
-        when($_ eq 'sixth'  ) { $modifier = 6; }
-        when($_ eq 'seventh') { $modifier = 7; }
-        when($_ eq 'eighth' ) { $modifier = 8; }
-        when($_ eq 'nineth' ) { $modifier = 9; }
-        when($_ eq 'tenth'  ) { $modifier = 10; }
-        default { print "$nick: Bad replacement modifier '$modifier'; valid modifiers are 'all', 'first', 'second', ..., 'tenth', 'last'\n"; exit 0; }
-      }
-
-      my $replacement = {};
-      $replacement->{'from'} = $from;
-      $replacement->{'to'} = $to;
-      $replacement->{'modifier'} = $modifier;
-
-      push @replacements, $replacement;
-      next;
-    }
-
-    if ($subcode =~ m/^\s*(and)?\s*s\/.*\//) {
-      $got_sub = 1;
-      $subcode =~ s/^\s*(and)?\s*s//;
-
-      my ($regex, $to);
-      my ($e, $r) = extract_delimited($subcode, '/');
-
-      if (defined $e) {
-        $regex = $e;
-        $regex =~ s/^\///;
-        $regex =~ s/\/$//;
-        $subcode = "/$r";
-      } else {
-        print "$nick: Unbalanced slashes.  Usage: !cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n";
-        exit 0;
-      }
-
-      ($e, $r) = extract_delimited($subcode, '/');
-
-      if (defined $e) {
-        $to = $e;
-        $to =~ s/^\///;
-        $to =~ s/\/$//;
-        $subcode = $r;
-      } else {
-        print "$nick: Unbalanced slashes.  Usage: !cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n";
-        exit 0;
-      }
-
-      my $suffix;
-      $suffix = $1 if $subcode =~ s/^([^ ]+)//;
-
-      if (length $suffix and $suffix =~ m/[^gi]/) {
-        print "$nick: Bad regex modifier '$suffix'.  Only 'i' and 'g' are allowed.\n";
-        exit 0;
-      }
-      if (defined $prevchange) {
-        $code = $prevchange;
-      } else {
-        print "$nick: No recent code to change.\n";
-        exit 0;
-      }
-
-      my $ret = eval {
-        my $ret;
-        my $a;
-        my $b;
-        my $c;
-        my $d;
-        my $e;
-        my $f;
-        my $g;
-        my $h;
-        my $i;
-        my $before;
-        my $after;
-
-        if (not length $suffix) {
-          $ret = $code =~ s|$regex|$to|;
-          $a = $1;
-          $b = $2;
-          $c = $3;
-          $d = $4;
-          $e = $5;
-          $f = $6;
-          $g = $7;
-          $h = $8;
-          $i = $9;
-          $before = $`;
-          $after = $';
-        } elsif ($suffix =~ /^i$/) {
-          $ret = $code =~ s|$regex|$to|i;
-          $a = $1;
-          $b = $2;
-          $c = $3;
-          $d = $4;
-          $e = $5;
-          $f = $6;
-          $g = $7;
-          $h = $8;
-          $i = $9;
-          $before = $`;
-          $after = $';
-        } elsif ($suffix =~ /^g$/) {
-          $ret = $code =~ s|$regex|$to|g;
-          $a = $1;
-          $b = $2;
-          $c = $3;
-          $d = $4;
-          $e = $5;
-          $f = $6;
-          $g = $7;
-          $h = $8;
-          $i = $9;
-          $before = $`;
-          $after = $';
-        } elsif ($suffix =~ /^ig$/ or $suffix =~ /^gi$/) {
-          $ret = $code =~ s|$regex|$to|gi;
-          $a = $1;
-          $b = $2;
-          $c = $3;
-          $d = $4;
-          $e = $5;
-          $f = $6;
-          $g = $7;
-          $h = $8;
-          $i = $9;
-          $before = $`;
-          $after = $';
-        }
-
-        if ($ret) {
-          $code =~ s/\$1/$a/g;
-          $code =~ s/\$2/$b/g;
-          $code =~ s/\$3/$c/g;
-          $code =~ s/\$4/$d/g;
-          $code =~ s/\$5/$e/g;
-          $code =~ s/\$6/$f/g;
-          $code =~ s/\$7/$g/g;
-          $code =~ s/\$8/$h/g;
-          $code =~ s/\$9/$i/g;
-          $code =~ s/\$`/$before/g;
-          $code =~ s/\$'/$after/g;
-        }
-
-        return $ret;
-      };
-
-      if ($@) {
-        print "$nick: $@\n";
-        exit 0;
-      }
-
-      if ($ret) {
-        $got_changes = 1;
-      }
-
-      $prevchange = $code;
-    }
-
-    if ($got_sub and not $got_changes) {
-      print "$nick: No substitutions made.\n";
-      exit 0;
-    } elsif ($got_sub and $got_changes) {
-      next;
-    }
-
-    last;
-  }
-
-  if ($#replacements > -1) {
-    @replacements = sort { $a->{'from'} cmp $b->{'from'} or $a->{'modifier'} <=> $b->{'modifier'} } @replacements;
-
-    my ($previous_from, $previous_modifier);
-
-    foreach my $replacement (@replacements) {
-      my $from = $replacement->{'from'};
-      my $to = $replacement->{'to'};
-      my $modifier = $replacement->{'modifier'};
-
-      if (defined $previous_from) {
-        if ($previous_from eq $from and $previous_modifier =~ /^\d+$/) {
-          $modifier -= $modifier - $previous_modifier;
-        }
-      }
-
-      if (defined $prevchange) {
-        $code = $prevchange;
-      } else {
-        print "$nick: No recent code to change.\n";
-        exit 0;
-      }
-
-      my $ret = eval {
-        my $got_change;
-
-        my ($first_char, $last_char, $first_bound, $last_bound);
-        $first_char = $1 if $from =~ m/^(.)/;
-        $last_char = $1 if $from =~ m/(.)$/;
-
-        if ($first_char =~ /\W/) {
-          $first_bound = '.';
+    while ($subcode =~ s/^\s*(and)?\s*undo//) {
+        splice @last_code, 0, 1;
+        if (not defined $last_code[0]) {
+            print "$nick: No more undos remaining.\n";
+            exit 0;
         } else {
-          $first_bound = '\b';
+            $code     = $last_code[0];
+            $got_undo = 1;
+        }
+    }
+
+    my @replacements;
+    my $prevchange  = $last_code[0];
+    my $got_changes = 0;
+
+    while (1) {
+        $got_sub     = 0;
+        $got_changes = 0;
+
+        if ($subcode =~ m/^\s*(and)?\s*remove \s*([^']+)?\s*'/) {
+            my $modifier = 'first';
+
+            $subcode =~ s/^\s*(and)?\s*//;
+            $subcode =~ s/remove\s*([^']+)?\s*//i;
+            $modifier = $1 if defined $1;
+            $modifier =~ s/\s+$//;
+
+            my ($e, $r) = extract_delimited($subcode, "'");
+
+            my $text;
+
+            if (defined $e) {
+                $text = $e;
+                $text =~ s/^'//;
+                $text =~ s/'$//;
+                $subcode = "replace $modifier '$text' with ''$r";
+            } else {
+                print "$nick: Unbalanced single quotes.  Usage: !cc remove [all, first, .., tenth, last] 'text' [and ...]\n";
+                exit 0;
+            }
+            next;
         }
 
-        if ($last_char =~ /\W/) {
-          $last_bound = '\B';
-        } else {
-          $last_bound = '\b';
+        if ($subcode =~ s/^\s*(and)?\s*add '//) {
+            $subcode = "'$subcode";
+
+            my ($e, $r) = extract_delimited($subcode, "'");
+
+            my $text;
+
+            if (defined $e) {
+                $text = $e;
+                $text =~ s/^'//;
+                $text =~ s/'$//;
+                $subcode = $r;
+
+                $got_sub     = 1;
+                $got_changes = 1;
+
+                if (not defined $prevchange) {
+                    print "$nick: No recent code to append to.\n";
+                    exit 0;
+                }
+
+                $code = $prevchange;
+                $code =~ s/$/ $text/;
+                $prevchange = $code;
+            } else {
+                print "$nick: Unbalanced single quotes.  Usage: !cc add 'text' [and ...]\n";
+                exit 0;
+            }
+            next;
         }
 
-        if ($modifier eq 'all') {
-          while ($code =~ s/($first_bound)$from($last_bound)/$1$to$2/) {
-            $got_change = 1;
-          }
-        } elsif ($modifier eq 'last') {
-          if ($code =~ s/(.*)($first_bound)$from($last_bound)/$1$2$to$3/) {
-            $got_change = 1;
-          }
-        } else {
-          my $count = 0;
-          my $unescaped = $from;
-          $unescaped =~ s/\\//g;
-          if ($code =~ s/($first_bound)$from($last_bound)/if (++$count == $modifier) { "$1$to$2"; } else { "$1$unescaped$2"; }/gex) {
-            $got_change = 1;
-          }
-        }
-        return $got_change;
-      };
+        if ($subcode =~ m/^\s*(and)?\s*replace\s*([^']+)?\s*'.*'\s*with\s*'.*'/i) {
+            $got_sub = 1;
+            my $modifier = 'first';
 
-      if ($@) {
-        print "$nick: $@\n";
+            $subcode =~ s/^\s*(and)?\s*//;
+            $subcode =~ s/replace\s*([^']+)?\s*//i;
+            $modifier = $1 if defined $1;
+            $modifier =~ s/\s+$//;
+
+            my ($from, $to);
+            my ($e, $r) = extract_delimited($subcode, "'");
+
+            if (defined $e) {
+                $from = $e;
+                $from =~ s/^'//;
+                $from =~ s/'$//;
+                $from    = quotemeta $from;
+                $subcode = $r;
+                $subcode =~ s/\s*with\s*//i;
+            } else {
+                print "$nick: Unbalanced single quotes.  Usage: !cc replace 'from' with 'to' [and ...]\n";
+                exit 0;
+            }
+
+            ($e, $r) = extract_delimited($subcode, "'");
+
+            if (defined $e) {
+                $to = $e;
+                $to =~ s/^'//;
+                $to =~ s/'$//;
+                $subcode = $r;
+            } else {
+                print "$nick: Unbalanced single quotes.  Usage: !cc replace 'from' with 'to' [and replace ... with ... [and ...]]\n";
+                exit 0;
+            }
+
+            given ($modifier) {
+                when ($_ eq 'all')     { }
+                when ($_ eq 'last')    { }
+                when ($_ eq 'first')   { $modifier = 1; }
+                when ($_ eq 'second')  { $modifier = 2; }
+                when ($_ eq 'third')   { $modifier = 3; }
+                when ($_ eq 'fourth')  { $modifier = 4; }
+                when ($_ eq 'fifth')   { $modifier = 5; }
+                when ($_ eq 'sixth')   { $modifier = 6; }
+                when ($_ eq 'seventh') { $modifier = 7; }
+                when ($_ eq 'eighth')  { $modifier = 8; }
+                when ($_ eq 'nineth')  { $modifier = 9; }
+                when ($_ eq 'tenth')   { $modifier = 10; }
+                default                { print "$nick: Bad replacement modifier '$modifier'; valid modifiers are 'all', 'first', 'second', ..., 'tenth', 'last'\n"; exit 0; }
+            }
+
+            my $replacement = {};
+            $replacement->{'from'}     = $from;
+            $replacement->{'to'}       = $to;
+            $replacement->{'modifier'} = $modifier;
+
+            push @replacements, $replacement;
+            next;
+        }
+
+        if ($subcode =~ m/^\s*(and)?\s*s\/.*\//) {
+            $got_sub = 1;
+            $subcode =~ s/^\s*(and)?\s*s//;
+
+            my ($regex, $to);
+            my ($e, $r) = extract_delimited($subcode, '/');
+
+            if (defined $e) {
+                $regex = $e;
+                $regex =~ s/^\///;
+                $regex =~ s/\/$//;
+                $subcode = "/$r";
+            } else {
+                print "$nick: Unbalanced slashes.  Usage: !cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n";
+                exit 0;
+            }
+
+            ($e, $r) = extract_delimited($subcode, '/');
+
+            if (defined $e) {
+                $to = $e;
+                $to =~ s/^\///;
+                $to =~ s/\/$//;
+                $subcode = $r;
+            } else {
+                print "$nick: Unbalanced slashes.  Usage: !cc s/regex/substitution/[gi] [and s/.../.../ [and ...]]\n";
+                exit 0;
+            }
+
+            my $suffix;
+            $suffix = $1 if $subcode =~ s/^([^ ]+)//;
+
+            if (length $suffix and $suffix =~ m/[^gi]/) {
+                print "$nick: Bad regex modifier '$suffix'.  Only 'i' and 'g' are allowed.\n";
+                exit 0;
+            }
+            if (defined $prevchange) { $code = $prevchange; }
+            else {
+                print "$nick: No recent code to change.\n";
+                exit 0;
+            }
+
+            my $ret = eval {
+
+                my $ret;
+
+                my $a;
+                my $b;
+                my $c;
+                my $d;
+                my $e;
+                my $f;
+                my $g;
+                my $h;
+                my $i;
+                my $before;
+                my $after;
+
+                if (not length $suffix) {
+                    $ret    = $code =~ s|$regex|$to|;
+                    $a      = $1;
+                    $b      = $2;
+                    $c      = $3;
+                    $d      = $4;
+                    $e      = $5;
+                    $f      = $6;
+                    $g      = $7;
+                    $h      = $8;
+                    $i      = $9;
+                    $before = $`;
+                    $after  = $';
+                } elsif ($suffix =~ /^i$/) {
+                    $ret    = $code =~ s|$regex|$to|i;
+                    $a      = $1;
+                    $b      = $2;
+                    $c      = $3;
+                    $d      = $4;
+                    $e      = $5;
+                    $f      = $6;
+                    $g      = $7;
+                    $h      = $8;
+                    $i      = $9;
+                    $before = $`;
+                    $after  = $';
+                } elsif ($suffix =~ /^g$/) {
+                    $ret    = $code =~ s|$regex|$to|g;
+                    $a      = $1;
+                    $b      = $2;
+                    $c      = $3;
+                    $d      = $4;
+                    $e      = $5;
+                    $f      = $6;
+                    $g      = $7;
+                    $h      = $8;
+                    $i      = $9;
+                    $before = $`;
+                    $after  = $';
+                } elsif ($suffix =~ /^ig$/ or $suffix =~ /^gi$/) {
+                    $ret    = $code =~ s|$regex|$to|gi;
+                    $a      = $1;
+                    $b      = $2;
+                    $c      = $3;
+                    $d      = $4;
+                    $e      = $5;
+                    $f      = $6;
+                    $g      = $7;
+                    $h      = $8;
+                    $i      = $9;
+                    $before = $`;
+                    $after  = $';
+                }
+
+                if ($ret) {
+                    $code =~ s/\$1/$a/g;
+                    $code =~ s/\$2/$b/g;
+                    $code =~ s/\$3/$c/g;
+                    $code =~ s/\$4/$d/g;
+                    $code =~ s/\$5/$e/g;
+                    $code =~ s/\$6/$f/g;
+                    $code =~ s/\$7/$g/g;
+                    $code =~ s/\$8/$h/g;
+                    $code =~ s/\$9/$i/g;
+                    $code =~ s/\$`/$before/g;
+                    $code =~ s/\$'/$after/g;
+                }
+
+                return $ret;
+            };
+
+            if ($@) {
+                print "$nick: $@\n";
+                exit 0;
+            }
+
+            if ($ret) { $got_changes = 1; }
+
+            $prevchange = $code;
+        }
+
+        if ($got_sub and not $got_changes) {
+            print "$nick: No substitutions made.\n";
+            exit 0;
+        } elsif ($got_sub and $got_changes) {
+            next;
+        }
+
+        last;
+    }
+
+    if ($#replacements > -1) {
+        @replacements = sort { $a->{'from'} cmp $b->{'from'} or $a->{'modifier'} <=> $b->{'modifier'} } @replacements;
+
+        my ($previous_from, $previous_modifier);
+
+        foreach my $replacement (@replacements) {
+            my $from     = $replacement->{'from'};
+            my $to       = $replacement->{'to'};
+            my $modifier = $replacement->{'modifier'};
+
+            if (defined $previous_from) {
+                if ($previous_from eq $from and $previous_modifier =~ /^\d+$/) { $modifier -= $modifier - $previous_modifier; }
+            }
+
+            if (defined $prevchange) { $code = $prevchange; }
+            else {
+                print "$nick: No recent code to change.\n";
+                exit 0;
+            }
+
+            my $ret = eval {
+                my $got_change;
+
+                my ($first_char, $last_char, $first_bound, $last_bound);
+                $first_char = $1 if $from =~ m/^(.)/;
+                $last_char  = $1 if $from =~ m/(.)$/;
+
+                if   ($first_char =~ /\W/) { $first_bound = '.'; }
+                else                       { $first_bound = '\b'; }
+
+                if   ($last_char =~ /\W/) { $last_bound = '\B'; }
+                else                      { $last_bound = '\b'; }
+
+                if ($modifier eq 'all') {
+                    while ($code =~ s/($first_bound)$from($last_bound)/$1$to$2/) { $got_change = 1; }
+                } elsif ($modifier eq 'last') {
+                    if ($code =~ s/(.*)($first_bound)$from($last_bound)/$1$2$to$3/) { $got_change = 1; }
+                } else {
+                    my $count     = 0;
+                    my $unescaped = $from;
+                    $unescaped =~ s/\\//g;
+                    if ($code =~ s/($first_bound)$from($last_bound)/if (++$count == $modifier) { "$1$to$2"; } else { "$1$unescaped$2"; }/gex) { $got_change = 1; }
+                }
+                return $got_change;
+            };
+
+            if ($@) {
+                print "$nick: $@\n";
+                exit 0;
+            }
+
+            if ($ret) {
+                $got_sub     = 1;
+                $got_changes = 1;
+            }
+
+            $prevchange        = $code;
+            $previous_from     = $from;
+            $previous_modifier = $modifier;
+        }
+
+        if ($got_sub and not $got_changes) {
+            print "$nick: No replacements made.\n";
+            exit 0;
+        }
+    }
+
+    open FILE, "> ideone_last_code.txt";
+
+    unless ($got_undo and not $got_sub) { unshift @last_code, $code; }
+
+    my $i = 0;
+    foreach my $line (@last_code) {
+        last if (++$i > $MAX_UNDO_HISTORY);
+        print FILE "$line\n";
+    }
+    close FILE;
+
+    if ($got_undo and not $got_sub) {
+        print "$nick: $code\n";
         exit 0;
-      }
-
-      if ($ret) {
-        $got_sub = 1;
-        $got_changes = 1;
-      }
-
-      $prevchange = $code;
-      $previous_from = $from;
-      $previous_modifier = $modifier;
     }
-
-    if ($got_sub and not $got_changes) {
-      print "$nick: No replacements made.\n";
-      exit 0;
-    }
-  }
-
-  open FILE, "> ideone_last_code.txt";
-
-  unless ($got_undo and not $got_sub) {
-    unshift @last_code, $code;
-  }
-
-  my $i = 0;
-  foreach my $line (@last_code) {
-    last if (++$i > $MAX_UNDO_HISTORY);
-    print FILE "$line\n";
-  }
-  close FILE;
-
-  if ($got_undo and not $got_sub) {
-    print "$nick: $code\n";
-    exit 0;
-  }
 }
 
 unless ($got_run) {
-  open FILE, ">> ideone_log.txt";
-  print FILE "$nick: $code\n";
+    open FILE, ">> ideone_log.txt";
+    print FILE "$nick: $code\n";
 }
 
 my $lang = "C99";
@@ -540,16 +522,16 @@ $show_link = 1 if $code =~ s/-showurl//i;
 my $found = 0;
 my @langs;
 foreach my $l (sort { uc $a cmp uc $b } keys %languages) {
-  push @langs, sprintf("      %-30s => %s", $l, $languages{$l}{'name'});
-  if (uc $lang eq uc $l) {
-    $lang = $l;
-    $found = 1;
-  }
+    push @langs, sprintf("      %-30s => %s", $l, $languages{$l}{'name'});
+    if (uc $lang eq uc $l) {
+        $lang  = $l;
+        $found = 1;
+    }
 }
 
 if (not $found) {
-  print "$nick: Invalid language '$lang'.  Supported languages are:\n", (join ",\n", @langs), "\n";
-  exit 0;
+    print "$nick: Invalid language '$lang'.  Supported languages are:\n", (join ",\n", @langs), "\n";
+    exit 0;
 }
 
 my $input = "";
@@ -563,48 +545,53 @@ my $precode = $preludes{$languages{$lang}{'id'}} . $code;
 $code = '';
 
 if ($languages{$lang}{'id'} == 1 or $languages{$lang}{'id'} == 11 or $languages{$lang}{'id'} == 34) {
-  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 .= "error: unmatched brackets for function '$ident';\n";
-      $body = $extract[1];
-    } else {
-      $body = $extract[0];
-      $precode .= $extract[1];
+        my @extract = extract_codeblock($potential_body, '{}');
+        my $body;
+        if (not defined $extract[0]) {
+            $output .= "error: unmatched brackets for function '$ident';\n";
+            $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";
-    $nooutput = "Success [no output].";
-  } else {
-    $code = "$prelude\n\n$precode\n\n$code\n";
-    $nooutput = "No output.";
-  }
+    if (not $has_main) {
+        $code     = "$prelude\n\n$code\n\nint main(int argc, char **argv) { $precode\n;\n return 0;}\n";
+        $nooutput = "Success [no output].";
+    } else {
+        $code     = "$prelude\n\n$precode\n\n$code\n";
+        $nooutput = "No output.";
+    }
 } else {
-  $code = $precode;
+    $code = $precode;
 }
 
-if ($languages{$lang}{'id'} == 1 or $languages{$lang}{'id'} == 11 or $languages{$lang}{'id'} == 35
-     or $languages{$lang}{'id'} == 27 or $languages{$lang}{'id'} == 10 or $languages{$lang}{'id'} == 34) {
-  $code = pretty($code)
+if (   $languages{$lang}{'id'} == 1
+    or $languages{$lang}{'id'} == 11
+    or $languages{$lang}{'id'} == 35
+    or $languages{$lang}{'id'} == 27
+    or $languages{$lang}{'id'} == 10
+    or $languages{$lang}{'id'} == 34)
+{
+    $code = pretty($code);
 }
 
 $code =~ s/\\n/\n/g if $languages{$lang}{'id'} == 13 or $languages{$lang}{'id'} == 101 or $languages{$lang}{'id'} == 45;
-$code =~ s/;/\n/g if $languages{$lang}{'id'} == 13 or $languages{$lang}{'id'} == 45;
+$code =~ s/;/\n/g   if $languages{$lang}{'id'} == 13 or $languages{$lang}{'id'} == 45;
 $code =~ s/\|n/\n/g;
 $code =~ s/^\s+//;
 $code =~ s/\s+$//;
@@ -615,33 +602,33 @@ my $url = $result->{link};
 
 # wait for compilation/execution to complete
 while (1) {
-  $result = get_result($soap->getSubmissionStatus($user, $pass, $url));
-  last if $result->{status} == 0;
-  sleep 1;
+    $result = get_result($soap->getSubmissionStatus($user, $pass, $url));
+    last if $result->{status} == 0;
+    sleep 1;
 }
 
 $result = get_result($soap->getSubmissionDetails($user, $pass, $url, 0, 0, 1, 1, 1));
 
-my $COMPILER_ERROR = 11;
-my $RUNTIME_ERROR = 12;
-my $TIMELIMIT = 13;
-my $SUCCESSFUL = 15;
-my $MEMORYLIMIT = 17;
+my $COMPILER_ERROR  = 11;
+my $RUNTIME_ERROR   = 12;
+my $TIMELIMIT       = 13;
+my $SUCCESSFUL      = 15;
+my $MEMORYLIMIT     = 17;
 my $ILLEGAL_SYSCALL = 19;
-my $INTERNAL_ERROR = 20;
+my $INTERNAL_ERROR  = 20;
 
 # signals extracted from ideone.com
 my @signame;
-$signame[0] = 'SIGZERO';
-$signame[1] = 'SIGHUP';
-$signame[2] = 'SIGINT';
-$signame[3] = 'SIGQUIT';
-$signame[4] = 'SIGILL';
-$signame[5] = 'SIGTRAP';
-$signame[6] = 'SIGABRT';
-$signame[7] = 'SIGBUS';
-$signame[8] = 'SIGFPE';
-$signame[9] = 'SIGKILL';
+$signame[0]  = 'SIGZERO';
+$signame[1]  = 'SIGHUP';
+$signame[2]  = 'SIGINT';
+$signame[3]  = 'SIGQUIT';
+$signame[4]  = 'SIGILL';
+$signame[5]  = 'SIGTRAP';
+$signame[6]  = 'SIGABRT';
+$signame[7]  = 'SIGBUS';
+$signame[8]  = 'SIGFPE';
+$signame[9]  = 'SIGKILL';
 $signame[10] = 'SIGUSR1';
 $signame[11] = 'SIGSEGV';
 $signame[12] = 'SIGUSR2';
@@ -703,36 +690,24 @@ $signame[67] = 'SIGPOLL';
 $signame[68] = 'SIGUNUSED';
 
 if ($result->{result} != $SUCCESSFUL or $languages{$lang}{'id'} == 13) {
-  $output .= $result->{cmpinfo};
-  $output =~ s/[\n\r]/ /g;
+    $output .= $result->{cmpinfo};
+    $output =~ s/[\n\r]/ /g;
 }
 
-  if ($result->{result} == $RUNTIME_ERROR) {
+if ($result->{result} == $RUNTIME_ERROR) {
     $output .= "\n[Runtime error]";
-    if ($result->{signal}) {
-      $output .= "\n[Signal: $signame[$result->{signal}] ($result->{signal})]";
-    }
-  } else {
-    if ($result->{signal}) {
-      $output .= "\n[Exit code: $result->{signal}]";
-    }
-  }
-
-if ($result->{result} == $TIMELIMIT) {
-  $output .= "\n[Time limit exceeded]";
+    if ($result->{signal}) { $output .= "\n[Signal: $signame[$result->{signal}] ($result->{signal})]"; }
+} else {
+    if ($result->{signal}) { $output .= "\n[Exit code: $result->{signal}]"; }
 }
 
-if ($result->{result} == $MEMORYLIMIT) {
-  $output .= "\n[Out of memory]";
-}
+if ($result->{result} == $TIMELIMIT) { $output .= "\n[Time limit exceeded]"; }
 
-if ($result->{result} == $ILLEGAL_SYSCALL) {
-  $output .= "\n[Disallowed system call]";
-}
+if ($result->{result} == $MEMORYLIMIT) { $output .= "\n[Out of memory]"; }
 
-if ($result->{result} == $INTERNAL_ERROR) {
-  $output .= "\n[Internal error]";
-}
+if ($result->{result} == $ILLEGAL_SYSCALL) { $output .= "\n[Disallowed system call]"; }
+
+if ($result->{result} == $INTERNAL_ERROR) { $output .= "\n[Internal error]"; }
 
 $output .= "\n" . $result->{stderr};
 $output .= "\n" . $result->{output};
@@ -747,7 +722,7 @@ $output =~ s/prog\.c:[:\s\d]*//g;
 $output =~ s/ld: warning: cannot find entry symbol _start; defaulting to [^ ]+//;
 $output =~ s/error: (.*?) error/error: $1; error/msg;
 
-my $left_quote = chr(226) . chr(128) . chr(152);
+my $left_quote  = chr(226) . chr(128) . chr(152);
 my $right_quote = chr(226) . chr(128) . chr(153);
 $output =~ s/$left_quote/'/g;
 $output =~ s/$right_quote/'/g;
@@ -755,49 +730,44 @@ $output =~ s/$right_quote/'/g;
 $output = $nooutput if $output =~ m/^\s+$/;
 
 unless ($got_run) {
-  print FILE localtime() . "\n";
-  print FILE "$nick: [ http://ideone.com/$url ] $output\n\n";
-  close FILE;
+    print FILE localtime() . "\n";
+    print FILE "$nick: [ http://ideone.com/$url ] $output\n\n";
+    close FILE;
 }
 
-if ($show_link) {
-  print "$nick: [ http://ideone.com/$url ] $output\n";
-} else {
-  print "$nick: $output\n";
-}
+if   ($show_link) { print "$nick: [ http://ideone.com/$url ] $output\n"; }
+else              { print "$nick: $output\n"; }
 
 # ---------------------------------------------
 
 sub get_result {
-  my $result = shift @_;
+    my $result = shift @_;
 
-  use Data::Dumper;
+    use Data::Dumper;
 
-  if ($result->fault) {
-    print join ', ', $result->faultcode, $result->faultstring, $result->faultdetail;
-    exit 0;
-  } else {
-    if ($result->result->{error} ne "OK") {
-      print "error\n";
-      print Dumper($result->result->{error});
-      exit 0;
+    if ($result->fault) {
+        print join ', ', $result->faultcode, $result->faultstring, $result->faultdetail;
+        exit 0;
     } else {
-      return $result->result;
+        if ($result->result->{error} ne "OK") {
+            print "error\n";
+            print Dumper($result->result->{error});
+            exit 0;
+        } else {
+            return $result->result;
+        }
     }
-  }
 }
 
 sub pretty {
-  my $code = join '', @_;
-  my $result;
+    my $code = join '', @_;
+    my $result;
 
-  my $pid = open2(\*IN, \*OUT, 'astyle -xUpf');
-  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 -xUpf');
+    print OUT "$code\n";
+    close OUT;
+    while (my $line = <IN>) { $result .= $line; }
+    close IN;
+    waitpid($pid, 0);
+    return $result;
 }
diff --git a/modules/insult.pl b/modules/insult.pl
index 2fe23e03..be76149a 100755
--- a/modules/insult.pl
+++ b/modules/insult.pl
@@ -9,9 +9,8 @@ use LWP::Simple;
 
 $_ = get("http://www.randominsults.net/");
 if (/<strong><i>(.*?)\s*<\/i><\/strong>/) {
-        print "@ARGV",': ' if @ARGV;
-        print "$1\n";
-}
-else {
-        print "yo momma!";
+    print "@ARGV", ': ' if @ARGV;
+    print "$1\n";
+} else {
+    print "yo momma!";
 }
diff --git a/modules/lookupbot.pl b/modules/lookupbot.pl
index e6f5d7bf..a81a0a69 100755
--- a/modules/lookupbot.pl
+++ b/modules/lookupbot.pl
@@ -11,11 +11,12 @@ use utf8;
 my $VERSION = '1.0.2';
 
 my %IRSSI = (
-    'authors' => 'Craig Andrews',
-    'contact' => 'craig@simplyspiffing.com',
-    'name'    => 'lookupbot',
+    'authors'     => 'Craig Andrews',
+    'contact'     => 'craig@simplyspiffing.com',
+    'name'        => 'lookupbot',
     'description' => 'Some kind of magical internet searcher',
-    'license' => 'Craig\'s Magical Freebie License');
+    'license'     => 'Craig\'s Magical Freebie License'
+);
 
 ## Changes ##
 # 0.0.1 - Initial version, not very good
@@ -38,7 +39,7 @@ my %IRSSI = (
 sub get_data {
     my $data = shift;
 
-    my @params = split / +/, $data;
+    my @params  = split / +/, $data;
     my $trigger = shift @params;
 
     $data = join ' ', @params;
@@ -56,34 +57,29 @@ sub get_data {
 #  $escape - URL encode the data before insertion? 1 = true, 0 = false
 ##
 my %url_cache;
+
 sub get_content {
     my ($url, $data, $escape, $cache) = @_;
 
     $data = escape($data) unless $escape == 0;
-    $url = sprintf($url, $data) if defined $data;
+    $url  = sprintf($url, $data) if defined $data;
 
     # Use the cache if requested
     my $timeout = time() - $cache;
-    if (defined $cache &&
-        $cache > 0 &&
-	exists $url_cache{$url} &&
-	$url_cache{$url}->{'time'} > $timeout) {
+    if (defined $cache && $cache > 0 && exists $url_cache{$url} && $url_cache{$url}->{'time'} > $timeout) {
 
-	return $url_cache{$url}->{'content'};
+        return $url_cache{$url}->{'content'};
     }
 
-    my $ua = LWP::UserAgent->new(agent => "ME");
+    my $ua     = LWP::UserAgent->new(agent => "ME");
     my $result = $ua->get($url, ('Accept-Charset' => 'utf-8,iso-8859-1,*'));
 
     my $content;
-    if ($result->is_success)
-    {
+    if ($result->is_success) {
         my $encoding = $result->content_encoding;
-        if ($encoding eq "") {
-            $encoding = is_utf8($result->content)?'utf-8':'iso-8859-1';
-        }
+        if ($encoding eq "") { $encoding = is_utf8($result->content) ? 'utf-8' : 'iso-8859-1'; }
         $content = decode($encoding, $result->content()) if $result->is_success;
-	$url_cache{$url} = {'time' => time(), 'content' => $content};
+        $url_cache{$url} = {'time' => time(), 'content' => $content};
     }
 
     return $content;
@@ -127,7 +123,7 @@ sub define_search {
 ##
 sub urban_search {
     my $content = shift;
-    my $term = shift;
+    my $term    = shift;
 
     my @rawlines = $content =~ /<div class=["'](meaning|definition|example|def_p)["']>(.+?)<\/?div/gism;
     my @lines;
@@ -137,22 +133,20 @@ sub urban_search {
     }
 
     my $definition;
-    my $def_word = 0;
+    my $def_word   = 0;
     my $paragraphs = 0;
 
-    while ($def_word <= 1 &&
-           $paragraphs <= 4 &&
-           scalar(@lines) > 0) {
+    while ($def_word <= 1 && $paragraphs <= 4 && scalar(@lines) > 0) {
 
         my $s = shift(@lines);
         $s =~ s/^\s*//;
         $s =~ s/\s*$//;
         $s =~ s/<.+?>//g;
 
-        if ($s =~ /(meaning|definition|def_p)/) {
-            $def_word++;
-        } elsif ($s =~ /example/) {
-# Do nothing
+        if ($s =~ /(meaning|definition|def_p)/) { $def_word++; }
+        elsif ($s =~ /example/) {
+
+            # Do nothing
         } elsif (length $s > 0) {
             $definition .= "$s\n";
             $paragraphs++;
@@ -173,15 +167,15 @@ sub profan_search {
 
     my %definitions;
     my $ix;
-    for ($ix = 0; $ix < @matches; $ix+=2) {
-        my $key = $matches[$ix+1];
+    for ($ix = 0; $ix < @matches; $ix += 2) {
+        my $key = $matches[$ix + 1];
         $key =~ tr/A-Z/a-z/;
         $definitions{$key} = $matches[$ix];
     }
 
     my @keys = sort keys %definitions;
 
-    $content = get_content('http://www.viz.co.uk/profanisaurus/'.$definitions{$keys[0]}, 1);
+    $content = get_content('http://www.viz.co.uk/profanisaurus/' . $definitions{$keys[0]}, 1);
     @matches = $content =~ /class=profandefinition>(.+)/;
 
     return join "\n", @matches;
@@ -219,11 +213,8 @@ sub wwotd_search {
     my @result;
     while ($blanks > 0 && scalar(@lines)) {
         my $line = shift @lines;
-        if (length $line) {
-            push @result, $line;
-        } else {
-            $blanks --;
-        }
+        if   (length $line) { push @result, $line; }
+        else                { $blanks--; }
     }
 
     return join "\n", @result;
@@ -232,6 +223,7 @@ sub wwotd_search {
 ##
 # Dictionary.com word of the day
 ##
+
 =cut
 sub wotd_search {
     my $content = shift;
@@ -244,6 +236,7 @@ sub wotd_search {
     return join ("\n", @lines);
 }
 =cut
+
 ##
 # Sloganizer
 ##
@@ -282,9 +275,7 @@ sub insult_search {
 sub limerick_preprocessor {
     my $parameter = shift;
 
-    if (!defined($parameter) || $parameter == 0) {
-        $parameter = 'random';
-    }
+    if (!defined($parameter) || $parameter == 0) { $parameter = 'random'; }
 
     return $parameter;
 }
@@ -305,9 +296,7 @@ sub limerick_search {
 sub bash_preprocessor {
     my $parameter = shift;
 
-    if (!defined($parameter) || $parameter == 0) {
-        $parameter = 'random';
-    }
+    if (!defined($parameter) || $parameter == 0) { $parameter = 'random'; }
 
     return $parameter;
 }
@@ -327,9 +316,7 @@ sub bash_search {
 sub memetic_preprocessor {
     my $parameter = shift;
 
-    if (!defined($parameter) || $parameter == 0) {
-        $parameter = 'random';
-    }
+    if (!defined($parameter) || $parameter == 0) { $parameter = 'random'; }
 
     return $parameter;
 }
@@ -348,17 +335,18 @@ sub memetic_search {
 # Only really useful as a privmsg
 ##
 sub tinyurl_search {
+
     my $content = shift;
-    my $term = shift;
+
+    my $term   = shift;
     my $server = shift;
-    my $nick = shift;
+    my $nick   = shift;
 
     my @lines = $content =~ /<blockquote><b>(.+?)</gism;
 
     my $result = '';
-    if (scalar(@lines)) {
-        $result = $lines[1];
-    }
+
+    if (scalar(@lines)) { $result = $lines[1]; }
 
     return $result;
 }
@@ -369,7 +357,7 @@ sub tinyurl_search {
 sub cricket_search {
     my $content = shift;
 
-    my @lines = grep {/England/} split /$/m, $content;
+    my @lines = grep { /England/ } split /$/m, $content;
 
     return $lines[0];
 }
@@ -388,8 +376,7 @@ sub cndb_search {
     my @raw = $content =~ m/class="bold">(.+?)<\/td>/gosm;
     return "" unless scalar(@raw);
     my @lines;
-    while (scalar(@raw) &&
-        $raw[0] !~ /(was this review helpful|login to rate this review|^\s*$)/i) {
+    while (scalar(@raw) && $raw[0] !~ /(was this review helpful|login to rate this review|^\s*$)/i) {
 
         my $l = shift @raw;
         push @lines, $l if $l !~ /\ /;
@@ -406,7 +393,7 @@ sub cndb_preprocessor {
 
     $parameter =~ s/(?<=\b)(\w)/\u$1/g;
     my @parts = split /\s+/, $parameter;
-    my $last = pop @parts;
+    my $last  = pop @parts;
     $last .= "," if scalar(@parts);
     unshift @parts, $last;
 
@@ -418,14 +405,14 @@ sub cndb_preprocessor {
 ##
 sub horoscope_search {
     my $content = shift;
-    my $term = shift;
+    my $term    = shift;
 
     $content =~ s/[\r\n]/ /gsm;
     my ($line) = $content =~ m|CHANGE $term HERE -->(.+)<!-- END $term HERE|i;
     $line =~ s/  +/ /g;
 
     if ($line eq "") {
-      return "No results found; signs of the Zodiac are Aquarius, Pisces, Aries, Taurus, Gemini, Cancer, Leo, Virgo, Libra, Scorpio, Sagittarius, Capricorn";
+        return "No results found; signs of the Zodiac are Aquarius, Pisces, Aries, Taurus, Gemini, Cancer, Leo, Virgo, Libra, Scorpio, Sagittarius, Capricorn";
     }
 
     $line =~ s/<ins class.*$//;
@@ -438,10 +425,10 @@ sub horoscope_search {
 ##
 sub horrorscope_search {
     my $content = shift;
-    my $term = shift;
+    my $term    = shift;
 
-    if ($term eq"") {
-      return "Usage: horrorscope sign; signs of the Zodiac are Aquarius, Pisces, Aries, Taurus, Gemini, Cancer, Leo, Virgo, Libra, Scorpio, Sagittarius, Capricorn";
+    if ($term eq "") {
+        return "Usage: horrorscope sign; signs of the Zodiac are Aquarius, Pisces, Aries, Taurus, Gemini, Cancer, Leo, Virgo, Libra, Scorpio, Sagittarius, Capricorn";
     }
 
     $content =~ s/[\r\n]/ /gsm;
@@ -449,7 +436,7 @@ sub horrorscope_search {
     $line =~ s/  +/ /g;
 
     if ($line eq "") {
-      return "No results found; signs of the Zodiac are Aquarius, Pisces, Aries, Taurus, Gemini, Cancer, Leo, Virgo, Libra, Scorpio, Sagittarius, Capricorn";
+        return "No results found; signs of the Zodiac are Aquarius, Pisces, Aries, Taurus, Gemini, Cancer, Leo, Virgo, Libra, Scorpio, Sagittarius, Capricorn";
     }
 
     return $line;
@@ -464,11 +451,11 @@ sub bored_search {
     my @stuff = $content =~ /<b><a href="(.+?)" target="_blank"><font .+?>(.+?)<\/font><\/a> - <\/b> *(.+?)<br>/g;
     my @lines;
     while (scalar(@stuff) > 0) {
-        my $url = shift @stuff;
+        my $url   = shift @stuff;
         my $title = shift @stuff;
-        my $desc = shift @stuff;
+        my $desc  = shift @stuff;
 
-        $url = 'http://www.bored.com'.$url unless $url =~ /^http/;
+        $url = 'http://www.bored.com' . $url unless $url =~ /^http/;
 
         my $line = "$title - $url\n$desc";
         push @lines, $line;
@@ -487,9 +474,9 @@ sub sick_search {
 
     my @stuff = $content =~ /<description><!\[CDATA\[(.+?)]]><\/description>/gosm;
 
-# Try and pick one with less than 5 lines ...
-    my $pick = 0;
-    my $brs = 0;
+    # Try and pick one with less than 5 lines ...
+    my $pick  = 0;
+    my $brs   = 0;
     my $count = 3;
     do {
         $pick = rand(scalar(@stuff));
@@ -520,23 +507,21 @@ sub joke_search {
 
 sub tdm_search {
     my $content = shift;
-    my $term = shift;
+    my $term    = shift;
 
     my @lines = $content =~ /<item>(.+?)<\/item>/gosm;
 
     my $id = rand(scalar(@lines));
-    if ($term =~ /^\d+$/ &&
-        $term > 0 &&
-        $term <= scalar(@lines)) {
+    if ($term =~ /^\d+$/ && $term > 0 && $term <= scalar(@lines)) {
 
-	$id = $term - 1;
+        $id = $term - 1;
     }
 
     my @item = grep { /<(title|description|link)>/ } split /\n/, $lines[$id];
     foreach (@item) {
-		s/^\s*//;
-		$_ = unescapeHTML($_);
-	}
+        s/^\s*//;
+        $_ = unescapeHTML($_);
+    }
 
     $item[1] =~ s/<.+?>//g;
     my ($url) = process_request('tinyurl', $item[1]);
@@ -544,7 +529,6 @@ sub tdm_search {
     return "$item[0]\n$item[2]\n$url";
 }
 
-
 ##
 # Random proverbs
 ##
@@ -571,73 +555,124 @@ sub proverb_search {
 # messages (i.e. 'in channel') the trigger must be prefixed by !
 # The only 'private only' responder at the moment is tinyurl
 ###
-my %ENGINES = ('!image' =>      {'url' => 'http://images.google.co.uk/images?hl=en&safe=off&q=%s',
-                                 'sub' => \&image_search,
-				 'cache' => 600},
-               '!google' =>     {'url' => 'http://www.google.co.uk/search?hl=en&q=%s',
-                                 'sub' => \&google_search},
-               '!define' =>     {'url' => 'http://www.google.co.uk/search?hl=en&q=define%%3A%%20%s',
-                                 'sub' => \&define_search},
-               '!urban' =>      {'url' => 'http://www.urbandictionary.com/define.php?term=%s',
-                                 'sub' => \&urban_search,
-				 'cache' => 60},
-               '!profan' =>     {'url' => 'http://www.viz.co.uk/profanisaurus/profan_results.php?profan=search&prof_search=%s',
-                                 'sub' => \&profan_search},
-               '!uwotd' =>      {'url' => 'http://feeds.urbandictionary.com/UrbanWordOfTheDay',
-                                 'sub' => \&uwotd_search,
-				 'cache' => 3600},
-               '!wwotd' =>      {'url' => 'http://home.comcast.net/~wwftd/Frame1.html',
-                                 'sub' => \&wwotd_search,
-				 'cache' => 3600},
-               '!wotd' =>       {'url' => 'http://dictionary.reference.com/wordoftheday/',
-                                 'sub' => \&wotd_search,
-				 'cache' => 3600},
-               '!slogan' =>     {'url' => 'http://www.sloganizer.net/en/?slogan=%s',
-                                'sub' => \&slogan_search},
-               '!insult' => {'url' => 'http://www.webinsult.com/',
-                                 'sub' => \&insult_search},
-               '!compliment' => {'url' => 'http://www.madsci.org/cgi-bin/cgiwrap/~lynn/jardin/SCG/',
-                                 'sub' => \&compliment_search},
-               '!limerick' =>       {'url' => 'http://limerickdb.com/?%s',
-                                 'sub' => \&limerick_search,
-                                 'pre' => \&limerick_preprocessor},
-               '!bash' =>       {'url' => 'http://bash.org/?%s',
-                                 'sub' => \&bash_search,
-                                 'pre' => \&bash_preprocessor},
-               '!memetic' =>    {'url' => 'http://www.memetic.org/%s',
-                                 'sub' => \&memetic_search,
-                                 'pre' => \&memetic_preprocessor},
-               '!cricket' =>    {'url' => 'http://www.cricinfo.com/rss/livescores.xml',
-                                 'sub' => \&cricket_search},
-               'tinyurl' =>     {'url' => 'http://tinyurl.com/create.php?url=%s',
-                                 'sub' => \&tinyurl_search,
-                                 'escape' => 0,
-				 'cache' => 3600},
-               '!cndb' =>       {'url' => 'http://cndb.com/actor.html?name=%s',
-                                 'sub' => \&cndb_search,
-                                 'pre' => \&cndb_preprocessor,
-				 'cache' => 3600},
-               '!horoscope' =>  {'url' => 'http://www.astrology-online.com/daily.htm',
-                                 'sub' => \&horoscope_search,
-				 'cache' => 3600},
-               '!horrorscope' =>  {'url' => 'http://www.emilystrange.com/beware/horrorscopes.cfm',
-                                 'sub' => \&horrorscope_search,
-				 'cache' => 3600},
-               '!bored' =>      {'url' => 'http://www.bored.com/',
-                                 'sub' => \&bored_search,
-				 'cache' => 3600},
-               '!procrastinate' =>      {'url' => 'http://www.bored.com/',
-                                 'sub' => \&bored_search,
-				 'cache' => 3600},
-               #'!sick' =>       {'url' => 'http://sickipedia.org/feeds/?1195996408.xml',
-               #                  'sub' => \&sick_search},
-               '!joke' =>       {'url' => 'http://www.ajokeaday.com/ChisteAlAzar.asp',
-                                 'sub' => \&joke_search},
-	       '!tdm' =>        {'url' => 'http://www.thedailymash.co.uk/rss.xml',
-	                         'sub' => \&tdm_search,
-				 'cache' => 3600},
-                 '!proverb' => {'url' => 'http://server52204.uk2net.com/b3taproverbs/',
-                                'sub' => \&proverb_search});
+my %ENGINES = (
+    '!image' => {
+        'url'   => 'http://images.google.co.uk/images?hl=en&safe=off&q=%s',
+        'sub'   => \&image_search,
+        'cache' => 600
+    },
+    '!google' => {
+        'url' => 'http://www.google.co.uk/search?hl=en&q=%s',
+        'sub' => \&google_search
+    },
+    '!define' => {
+        'url' => 'http://www.google.co.uk/search?hl=en&q=define%%3A%%20%s',
+        'sub' => \&define_search
+    },
+    '!urban' => {
+        'url'   => 'http://www.urbandictionary.com/define.php?term=%s',
+        'sub'   => \&urban_search,
+        'cache' => 60
+    },
+    '!profan' => {
+        'url' => 'http://www.viz.co.uk/profanisaurus/profan_results.php?profan=search&prof_search=%s',
+        'sub' => \&profan_search
+    },
+    '!uwotd' => {
+        'url'   => 'http://feeds.urbandictionary.com/UrbanWordOfTheDay',
+        'sub'   => \&uwotd_search,
+        'cache' => 3600
+    },
+    '!wwotd' => {
+        'url'   => 'http://home.comcast.net/~wwftd/Frame1.html',
+        'sub'   => \&wwotd_search,
+        'cache' => 3600
+    },
+    '!wotd' => {
+        'url'   => 'http://dictionary.reference.com/wordoftheday/',
+        'sub'   => \&wotd_search,
+        'cache' => 3600
+    },
+    '!slogan' => {
+        'url' => 'http://www.sloganizer.net/en/?slogan=%s',
+        'sub' => \&slogan_search
+    },
+    '!insult' => {
+        'url' => 'http://www.webinsult.com/',
+        'sub' => \&insult_search
+    },
+    '!compliment' => {
+        'url' => 'http://www.madsci.org/cgi-bin/cgiwrap/~lynn/jardin/SCG/',
+        'sub' => \&compliment_search
+    },
+    '!limerick' => {
+        'url' => 'http://limerickdb.com/?%s',
+        'sub' => \&limerick_search,
+        'pre' => \&limerick_preprocessor
+    },
+    '!bash' => {
+        'url' => 'http://bash.org/?%s',
+        'sub' => \&bash_search,
+        'pre' => \&bash_preprocessor
+    },
+    '!memetic' => {
+        'url' => 'http://www.memetic.org/%s',
+        'sub' => \&memetic_search,
+        'pre' => \&memetic_preprocessor
+    },
+    '!cricket' => {
+        'url' => 'http://www.cricinfo.com/rss/livescores.xml',
+        'sub' => \&cricket_search
+    },
+    'tinyurl' => {
+        'url'    => 'http://tinyurl.com/create.php?url=%s',
+        'sub'    => \&tinyurl_search,
+        'escape' => 0,
+        'cache'  => 3600
+    },
+    '!cndb' => {
+        'url'   => 'http://cndb.com/actor.html?name=%s',
+        'sub'   => \&cndb_search,
+        'pre'   => \&cndb_preprocessor,
+        'cache' => 3600
+    },
+    '!horoscope' => {
+        'url'   => 'http://www.astrology-online.com/daily.htm',
+        'sub'   => \&horoscope_search,
+        'cache' => 3600
+    },
+    '!horrorscope' => {
+        'url'   => 'http://www.emilystrange.com/beware/horrorscopes.cfm',
+        'sub'   => \&horrorscope_search,
+        'cache' => 3600
+    },
+    '!bored' => {
+        'url'   => 'http://www.bored.com/',
+        'sub'   => \&bored_search,
+        'cache' => 3600
+    },
+    '!procrastinate' => {
+        'url'   => 'http://www.bored.com/',
+        'sub'   => \&bored_search,
+        'cache' => 3600
+    },
+
+    #'!sick' =>       {'url' => 'http://sickipedia.org/feeds/?1195996408.xml',
+    #                  'sub' => \&sick_search},
+    '!joke' => {
+        'url' => 'http://www.ajokeaday.com/ChisteAlAzar.asp',
+        'sub' => \&joke_search
+    },
+    '!tdm' => {
+        'url'   => 'http://www.thedailymash.co.uk/rss.xml',
+        'sub'   => \&tdm_search,
+        'cache' => 3600
+    },
+    '!proverb' => {
+        'url' => 'http://server52204.uk2net.com/b3taproverbs/',
+        'sub' => \&proverb_search
+    }
+);
 
 sub process_request {
     my ($trigger, $term, $server, $nick, $target) = @_;
@@ -645,54 +680,50 @@ sub process_request {
     my $result = '';
     if (exists $ENGINES{$trigger}) {
 
-        my $url = $ENGINES{$trigger}->{'url'};
-        my $sub = $ENGINES{$trigger}->{'sub'};
-        my $pre = exists $ENGINES{$trigger}->{'pre'} ?
-            $ENGINES{$trigger}->{'pre'} : undef;
-        my $escape = exists $ENGINES{$trigger}->{'escape'} ?
-            $ENGINES{$trigger}->{'escape'} : 1;
-        my $cache = exists $ENGINES{$trigger}->{'cache'} ?
-            $ENGINES{$trigger}->{'cache'} : 0;
+        my $url    = $ENGINES{$trigger}->{'url'};
+        my $sub    = $ENGINES{$trigger}->{'sub'};
+        my $pre    = exists $ENGINES{$trigger}->{'pre'} ? $ENGINES{$trigger}->{'pre'} : undef;
+        my $escape = exists $ENGINES{$trigger}->{'escape'} ? $ENGINES{$trigger}->{'escape'} : 1;
+        my $cache  = exists $ENGINES{$trigger}->{'cache'} ? $ENGINES{$trigger}->{'cache'} : 0;
 
-# Pre-process the parameter if a pre function is defined
+        # Pre-process the parameter if a pre function is defined
         $term = $pre->($term) if defined $pre;
 
-# Get the content from the URL
+        # Get the content from the URL
         my $content = get_content($url, $term, $escape, $cache);
 
-# Get the results of the search
+        # Get the results of the search
         $result = $sub->($content, $term, $server, $nick, $target) if defined $content;
-    }
-    else
-    {
-# Quit if this isn't for us
+    } else {
+
+        # Quit if this isn't for us
         return undef;
     }
 
-# Split the resulting lines at linebreaks or
-# whitespace delimited lines up to 400 characters long
-# to prevent IRSSI truncating the output lines
-	my @lines = $result =~ /(.{0,400})(?:\r|\n|\s+|$)/g;
-	@lines = () unless @lines;
+    # Split the resulting lines at linebreaks or
+    # whitespace delimited lines up to 400 characters long
+    # to prevent IRSSI truncating the output lines
+    my @lines = $result =~ /(.{0,400})(?:\r|\n|\s+|$)/g;
+    @lines = () unless @lines;
 
-	my @output = ();
-	foreach my $text (@lines) {
-		next if $text =~ /^\s*$/;
+    my @output = ();
+    foreach my $text (@lines) {
+        next if $text =~ /^\s*$/;
 
-# Strip HTML
+        # Strip HTML
         $text =~ s/<(.*?)>/ /g;
         $text = unescapeHTML($text);
 
-# Strip non-printable characters
+        # Strip non-printable characters
         $text =~ s/[^[:print:]]/ /g;
 
-# Sort out whitespace
+        # Sort out whitespace
         $text =~ s/ +/ /g;
         $text =~ s/^ *//;
         $text =~ s/ *$//;
 
-	push @output, $text;
-	}
+        push @output, $text;
+    }
 
     @output = ('No results found') unless scalar(@output) > 0;
 
@@ -719,51 +750,48 @@ sub public_responder {
     my $result;
     my $func;
 
-# If this is a public message and the trigger has no !, silently ignore it
+    # If this is a public message and the trigger has no !, silently ignore it
     return if ($nick ne $target && $trigger !~ /^!/);
 
-# If the trigger exists, call the URL and process the result
+    # If the trigger exists, call the URL and process the result
     my @lines = process_request($trigger, $term, $server, $nick, $target);
 
-# Display if necessary
+    # Display if necessary
     if (@lines) {
-        $server->command("msg $target -!- $_")
-            for grep { /./ } @lines;
+        $server->command("msg $target -!- $_") for grep { /./ } @lines;
     }
 }
 
 sub main {
-  my ($trigger, $term);
+    my ($trigger, $term);
 
-  $trigger = shift(@ARGV);
-  $term = join(' ', @ARGV);
+    $trigger = shift(@ARGV);
+    $term    = join(' ', @ARGV);
 
-  if (not defined $trigger) {
-    print "Usage: $0 <trigger> [terms]";
-    exit 1;
-  }
-
-  if ($trigger eq "list") {
-    my $comma = "Triggers: ";
-    foreach my $key (sort keys(%ENGINES)) {
-      print "$comma$key";
-      $comma = ", ";
+    if (not defined $trigger) {
+        print "Usage: $0 <trigger> [terms]";
+        exit 1;
     }
-    print "\n";
-    exit 1;
-  }
 
-  $trigger =~ s/^/!/;
+    if ($trigger eq "list") {
+        my $comma = "Triggers: ";
+        foreach my $key (sort keys(%ENGINES)) {
+            print "$comma$key";
+            $comma = ", ";
+        }
+        print "\n";
+        exit 1;
+    }
 
-  my @lines = process_request($trigger, $term, "server", "nick", "target");
+    $trigger =~ s/^/!/;
 
-  my $result = join(' ', @lines);
+    my @lines = process_request($trigger, $term, "server", "nick", "target");
 
-  if ($term ne "") {
-    print "$term: ";
-  }
+    my $result = join(' ', @lines);
 
-  print $result . "\n";
+    if ($term ne "") { print "$term: "; }
+
+    print $result . "\n";
 }
 
 main;
diff --git a/modules/love_quote.pl b/modules/love_quote.pl
index 7b69cf73..3513c0b0 100755
--- a/modules/love_quote.pl
+++ b/modules/love_quote.pl
@@ -13,15 +13,16 @@ my ($text, $t);
 my $debug = 0;
 
 my %cache_opt = (
-  'namespace' => 'lwp-cache',
-  'cache_root' => File::Spec->catfile(File::HomeDir->my_home, '.lwpcache'),
-  'default_expires_in' => 60 * 60 * 24 * 100 );
+    'namespace'          => 'lwp-cache',
+    'cache_root'         => File::Spec->catfile(File::HomeDir->my_home, '.lwpcache'),
+    'default_expires_in' => 60 * 60 * 24 * 100
+);
 my $ua = LWP::UserAgent::WithCache->new(\%cache_opt);
 
 $ua->agent("Mozilla/5.0");
 
 my $response;
-my $page = 1;
+my $page  = 1;
 my $pages = undef;
 my @quotes;
 
@@ -30,81 +31,78 @@ my @quotes;
 
 while (1) {
     my $arguments = "love you";
-    my $author = "";
+    my $author    = "";
 
     $arguments =~ s/\$nick/me/gi;
     $arguments =~ s/\s/+/g;
 
     if ($arguments =~ m/\-\-author[\s\+]+(.*)/i) {
-      $author = $1;
-      $arguments =~ s/\-\-author[\s\+]+(.*)//i;
+        $author = $1;
+        $arguments =~ s/\-\-author[\s\+]+(.*)//i;
     }
 
     # print "search: [$arguments]; author: [$author]\n";
     if ((length $arguments < 4) && ($author eq "")) {
-      print "Quote search parameter too small.\n";
-      die;
+        print "Quote search parameter too small.\n";
+        die;
     }
 
     if ((length $author > 0) && (length $author < 3)) {
-      print "Quote author parameter too small.\n";
-      die;
+        print "Quote author parameter too small.\n";
+        die;
     }
 
-
     $arguments =~ s/\++$//;
-    $author =~ s/\++$//;
+    $author    =~ s/\++$//;
 
-#    print "http://www.quotationspage.com/search.php3?Search=$arguments&startsearch=Search&Author=$author&C=mgm&C=motivate&C=classic&C=coles&C=poorc&C=lindsly&C=net&C=devils&C=contrib&page=$page\n";
-    $response = $ua->get("http://www.quotationspage.com/search.php3?Search=$arguments&startsearch=Search&Author=$author&C=mgm&C=motivate&C=classic&C=coles&C=poorc&C=lindsly&C=net&C=contrib&page=$page");
+    #    print "http://www.quotationspage.com/search.php3?Search=$arguments&startsearch=Search&Author=$author&C=mgm&C=motivate&C=classic&C=coles&C=poorc&C=lindsly&C=net&C=devils&C=contrib&page=$page\n";
+    $response = $ua->get(
+        "http://www.quotationspage.com/search.php3?Search=$arguments&startsearch=Search&Author=$author&C=mgm&C=motivate&C=classic&C=coles&C=poorc&C=lindsly&C=net&C=contrib&page=$page"
+    );
 
-  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;
+    $text = $response->content;
 
-  while ($text =~ m/<dt class="quote"><a.*?>(.*?)<\/a>.*?<dd class="author"><div.*?><a.*?>.*?<b>(.*?)<\/b>/g) {
-    $t = "\"$1\" -- $2.";
-    push @quotes, $t;
-    print "Added '$t'\n" if $debug;
-    print "$#quotes\n" if $debug;
-  }
+    while ($text =~ m/<dt class="quote"><a.*?>(.*?)<\/a>.*?<dd class="author"><div.*?><a.*?>.*?<b>(.*?)<\/b>/g) {
+        $t = "\"$1\" -- $2.";
+        push @quotes, $t;
+        print "Added '$t'\n" if $debug;
+        print "$#quotes\n"   if $debug;
+    }
 
-  if ($text =~ m/Page \d+ of (\d+)/) {
-    $pages = $1;
-    $page++;
-    last if $page > $pages;
-    print "Pages: $pages; fetching page $page\n" if $debug;
-  } else {
-    last;
-  }
+    if ($text =~ m/Page \d+ of (\d+)/) {
+        $pages = $1;
+        $page++;
+        last                                         if $page > $pages;
+        print "Pages: $pages; fetching page $page\n" if $debug;
+    } else {
+        last;
+    }
 
-  if ($#quotes < 0) {
-    print "No results found.\n";
-    die;
-  }
+    if ($#quotes < 0) {
+        print "No results found.\n";
+        die;
+    }
 }
 
 # print "Total quotes: ", $#quotes + 1, "\n";
 
 if ($#quotes < 0) {
-  print "No results found.\n";
-  die;
+    print "No results found.\n";
+    die;
 }
 
-
 $t = $quotes[int rand($#quotes + 1)];
 
-if ($#ARGV > -1) {
-  $t = "" . ($#quotes + 1) . " matching quote" . (($#quotes + 1) != 1 ? "s" : "") . " found. $t";
-}
+if ($#ARGV > -1) { $t = "" . ($#quotes + 1) . " matching quote" . (($#quotes + 1) != 1 ? "s" : "") . " found. $t"; }
 
-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;
diff --git a/modules/man.pl b/modules/man.pl
index 093b6847..13682d1c 100755
--- a/modules/man.pl
+++ b/modules/man.pl
@@ -11,8 +11,8 @@ use LWP::Simple;
 my ($result, $manpage, $section, $text, $name, $includes, $prototype, $conforms, $description);
 
 if ($#ARGV < 0) {
-  print "Which command would you like information about?\n";
-  die;
+    print "Which command would you like information about?\n";
+    die;
 }
 
 $manpage = join("+", @ARGV);
@@ -20,92 +20,76 @@ $section = 8;
 my $loop = 1;
 
 if ($manpage =~ m/([0-9]+)\+(.*)/) {
-  $section = $1;
-  $manpage = $2;
-  $loop = 0;
+    $section = $1;
+    $manpage = $2;
+    $loop    = 0;
 }
 
 $manpage =~ s/\+.*$//;
 
 my $get_text;
 do {
-#  $text = get("http://www.freebsd.org/cgi/man.cgi?query=$manpage&sektion=$section&apropos=0&manpath=FreeBSD+6.2-RELEASE&format=ascii");
+    #  $text = get("http://www.freebsd.org/cgi/man.cgi?query=$manpage&sektion=$section&apropos=0&manpath=FreeBSD+6.2-RELEASE&format=ascii");
 
-  $get_text = get("http://www.freebsd.org/cgi/man.cgi?query=$manpage&sektion=$section&apropos=0&manpath=SuSE+Linux%2Fi386+11.3&format=ascii");
+    $get_text = get("http://www.freebsd.org/cgi/man.cgi?query=$manpage&sektion=$section&apropos=0&manpath=SuSE+Linux%2Fi386+11.3&format=ascii");
 
+    $text = substr($get_text, 0, 5000);
 
-  $text = substr($get_text, 0, 5000);
-#  print '['.length($text).']'."\n";
+    #  print '['.length($text).']'."\n";
 
-  if ($text =~ m/Sorry, no data found/)
-  {
-    $section--;
+    if ($text =~ m/Sorry, no data found/) {
+        $section--;
 
-    if ($section == 0 || $loop == 0) {
-      $section++;
-      if ($section == 1 && $loop == 1) {
-        print "No information found for $manpage in any of the sections.\n";
-      } else {
-        print "No information found for $manpage in section $section.\n";
-      }
-      exit 0;
+        if ($section == 0 || $loop == 0) {
+            $section++;
+            if   ($section == 1 && $loop == 1) { print "No information found for $manpage in any of the sections.\n"; }
+            else                               { print "No information found for $manpage in section $section.\n"; }
+            exit 0;
+        }
+    } else {
+        $loop = 0;
     }
-  } else { $loop = 0; }
 } while ($loop);
 
 $text =~ m/^\s+NAME/gsm;
-if ($text =~ m/(.*?)SYNOPSIS/gsi) {
-  $name = $1;
-}
+if ($text =~ m/(.*?)SYNOPSIS/gsi) { $name = $1; }
 
 my $i = 0;
 while ($text =~ m/#include <(.*?)>/gsi) {
-  if (not $includes =~ /$1/) {
-    $includes .= ", " if ($i > 0);
-    $includes .= "$1";
-    $i++;
-  }
+    if (not $includes =~ /$1/) {
+        $includes .= ", " if ($i > 0);
+        $includes .= "$1";
+        $i++;
+    }
 }
 
-$prototype = "$1 $2$manpage($3);"
-  if ($text =~ m/SYNOPSIS.*^\s+(.*?)\s+(\*?)$manpage\s*\((.*?)\)\;?\n.*DESC/ms);
+$prototype = "$1 $2$manpage($3);" if ($text =~ m/SYNOPSIS.*^\s+(.*?)\s+(\*?)$manpage\s*\((.*?)\)\;?\n.*DESC/ms);
 
 if ($text =~ m/DESCRIPTION(.*?)$manpage(.*?)\./si) {
-  my $foo = $1;
-  my $bar = $2;
-  $foo =~ s/\r//g;
-  $foo =~ s/\n//g;
-  $foo =~ s/\s+/ /g;
-  $foo =~ s/^\s+//;
-  if ($foo =~ /^NOTE/) {
-    $description = "$foo$manpage$bar";
-  } else {
-    $description = "$manpage$bar";
-  }
-  $description =~ s/\-\s+//g;
+    my $foo = $1;
+    my $bar = $2;
+    $foo =~ s/\r//g;
+    $foo =~ s/\n//g;
+    $foo =~ s/\s+/ /g;
+    $foo =~ s/^\s+//;
+    if   ($foo =~ /^NOTE/) { $description = "$foo$manpage$bar"; }
+    else                   { $description = "$manpage$bar"; }
+    $description =~ s/\-\s+//g;
 }
 
-if ($get_text =~ m/^CONFORMING TO.*?^\s+The\s$manpage\s.*conforms to\s(.*?)$/ms) {
-  $conforms = $1;
-  } elsif ($get_text =~ m/^CONFORMING TO.*?^\s+The\s+$manpage\s+.*?is\s+compatible\s+with\s+(.*?)$/ms) {
-  $conforms = "$1 ...";
-} elsif ($get_text =~ m/^CONFORMING TO.*?^\s+(.*?)\.\s/ms or
-         $get_text =~ m/^CONFORMING TO.*?^\s+(.*?)$/ms) {
-  $conforms = $1;
-}
+if    ($get_text =~ m/^CONFORMING TO.*?^\s+The\s$manpage\s.*conforms to\s(.*?)$/ms)                       { $conforms = $1; }
+elsif ($get_text =~ m/^CONFORMING TO.*?^\s+The\s+$manpage\s+.*?is\s+compatible\s+with\s+(.*?)$/ms)        { $conforms = "$1 ..."; }
+elsif ($get_text =~ m/^CONFORMING TO.*?^\s+(.*?)\.\s/ms or $get_text =~ m/^CONFORMING TO.*?^\s+(.*?)$/ms) { $conforms = $1; }
 
 $result = "";
-$result .= "$name - " if (not defined $includes and defined $name);
+$result .= "$name - "               if (not defined $includes and defined $name);
 $result .= "Includes: $includes - " if (defined $includes);
-$result .= "$prototype - " if (defined $prototype);
+$result .= "$prototype - "          if (defined $prototype);
 
 $result .= $description;
 
-if ($section == 3) {
-  $result .= " - http://www.iso-9899.info/man?$manpage";
-} else {
-  $result .= " - http://www.freebsd.org/cgi/man.cgi?sektion=$section&query=$manpage";
-}
+if   ($section == 3) { $result .= " - http://www.iso-9899.info/man?$manpage"; }
+else                 { $result .= " - http://www.freebsd.org/cgi/man.cgi?sektion=$section&query=$manpage"; }
 
 $result .= " - $conforms" if (defined $conforms);
 
diff --git a/modules/map.pl b/modules/map.pl
index 7fef4324..e6882d84 100755
--- a/modules/map.pl
+++ b/modules/map.pl
@@ -8,20 +8,19 @@ use LWP::Simple;
 
 my ($text, $buffer, $location);
 
-if ($#ARGV < 0)
-{
-  print "Try again. Please specify the location you would like to search for nearby cities around.\n";
-  die;
+if ($#ARGV < 0) {
+    print "Try again. Please specify the location you would like to search for nearby cities around.\n";
+    die;
 }
 
 $location = join("+", @ARGV);
 
 $location =~ s/,/%2C/;
 
-if ($location =~ m/\+-(.*)/)
-{
-  # -arguments?
-  $location =~ s/\+-.*//;
+if ($location =~ m/\+-(.*)/) {
+
+    # -arguments?
+    $location =~ s/\+-.*//;
 }
 
 $text = get("http://weather.yahoo.com/search/weather2?p=$location");
@@ -29,74 +28,66 @@ $text = get("http://weather.yahoo.com/search/weather2?p=$location");
 $location =~ s/\+/ /g;
 $location =~ s/%2C/,/g;
 
-if ($text =~ m/No match found/)
-{
-  print "$location is not a valid location for this service.\n";
-  die;
+if ($text =~ m/No match found/) {
+    print "$location is not a valid location for this service.\n";
+    die;
 }
 
 my $found = 0;
 my $buf;
 my $i;
 
-if ($text =~ m/location matches\:/g)
-{
-  $buf = "Multiple locations found: ";
+if ($text =~ m/location matches\:/g) {
+    $buf = "Multiple locations found: ";
 
-  while ($text =~ m/<a\shref="\/forecast\/(.*?)">(.*?)<\/a>/g)
-  {
-    $i = $1;
-    $buffer = $2;
+    while ($text =~ m/<a\shref="\/forecast\/(.*?)">(.*?)<\/a>/g) {
+        $i      = $1;
+        $buffer = $2;
 
-    $buffer =~ s/<b>//g;
-    $buffer =~ s/<\/b>//g;
-    $buffer =~ s/^\s+//;
+        $buffer =~ s/<b>//g;
+        $buffer =~ s/<\/b>//g;
+        $buffer =~ s/^\s+//;
 
-    $buf = $buf . "$buffer - ";
+        $buf = $buf . "$buffer - ";
 
-    if ($location =~ m/$buffer/i)
-    {
-      $text = get("http://weather.yahoo.com/forecast/$i");
-      $found = 1;
+        if ($location =~ m/$buffer/i) {
+            $text  = get("http://weather.yahoo.com/forecast/$i");
+            $found = 1;
+        }
+    }
+    $buf = $buf . "please specify one of these.\n";
+    if (not $found) {
+        print $buf;
+        die;
     }
-  }
-  $buf = $buf. "please specify one of these.\n";
-  if (not $found)
-  {
-    print $buf;
-    die;
-  }
 }
 
-  my ($country, $state, $city);
+my ($country, $state, $city);
 
-  $text =~ m/<a href="\/">Weather<\/a>\s>/g;
-  $text =~ m/<a href=.*?>(.*?)<\/a>\s>/g;
-  $country = $1;
+$text =~ m/<a href="\/">Weather<\/a>\s>/g;
+$text =~ m/<a href=.*?>(.*?)<\/a>\s>/g;
+$country = $1;
 
-  if ($country eq "North America")
-  {
+if ($country eq "North America") {
     $text =~ m/<a href=.*?>(.*?)<\/a>\s>/g;
     $country = $1;
-  }
+}
 
-  if ($country ne "Canada")
-  {
+if ($country ne "Canada") {
     $text =~ m/<a href=.*?>(.*?)<\/a>\s>/g;
     $state = $1;
-  }
+}
 
-  $text =~ m/^(.*?)<\/b><\/font>/mg;
-  $city = $1;
+$text =~ m/^(.*?)<\/b><\/font>/mg;
+$city = $1;
 
-  $text =~ m/Nearby.*?Locations/sgi;
+$text =~ m/Nearby.*?Locations/sgi;
 
-  print "$country, $state, $city - Nearby Locations: ";
+print "$country, $state, $city - Nearby Locations: ";
 
-  while ($text =~ m/<a href=\"\/forecast\/.*?\.html\">(.*?)<\/a>/gi)
-  {
+while ($text =~ m/<a href=\"\/forecast\/.*?\.html\">(.*?)<\/a>/gi) {
     $buf = $1;
     $buf =~ s/<.*?>//gi;
     print "$buf, ";
-  }
-  print "\n";
+}
+print "\n";
diff --git a/modules/math.pl b/modules/math.pl
index eb315f4e..6f8daaf9 100755
--- a/modules/math.pl
+++ b/modules/math.pl
@@ -11,15 +11,14 @@ use Math::Units qw(convert);
 my ($arguments, $response, $invalid, @conversion);
 
 my @valid_keywords = (
-  'sin', 'cos', 'tan', 'atan', 'exp', 'int', 'hex', 'oct', 'log', 'sqrt',
-  'floor', 'ceil', 'asin', 'acos', 'log10', 'sinh', 'cosh', 'tanh', 'abs',
-  'pi', 'deg2rad', 'rad2deg', 'atan2', 'cbrt'
+    'sin',   'cos',     'tan',     'atan',  'exp',   'int',  'hex',  'oct',  'log', 'sqrt',
+    'floor', 'ceil',    'asin',    'acos',  'log10', 'sinh', 'cosh', 'tanh', 'abs',
+    'pi',    'deg2rad', 'rad2deg', 'atan2', 'cbrt'
 );
 
-if ($#ARGV < 0)
-{
-  print "Dumbass.\n";
-  exit 0;
+if ($#ARGV < 0) {
+    print "Dumbass.\n";
+    exit 0;
 }
 
 $arguments = join(' ', @ARGV);
@@ -28,44 +27,41 @@ my $orig_arguments = $arguments;
 $arguments =~ s/(the )*(ultimate )*answer.*question of life(,? the universe,? and everything)?\s?/42/gi;
 $arguments =~ s/(the )*(ultimate )*meaning of (life|existence|everything)?/42/gi;
 
-if ($arguments =~ s/(\d+\s?)([^ ]+)\s+to\s+([^ ]+)\s*$/$1/) {
-  @conversion = ($2, $3);
-}
+if ($arguments =~ s/(\d+\s?)([^ ]+)\s+to\s+([^ ]+)\s*$/$1/) { @conversion = ($2, $3); }
 
-if ($arguments =~ m/([\$`\|{}"'#@=?\[\]])/ or $arguments =~ m/(~~)/) {
-  $invalid = $1;
-} else {
-  while ($arguments =~ /([a-zA-Z0-9]+)/g) {
-    my $keyword = $1;
-    next if $keyword =~ m/^[0-9]+$/;
-    $invalid = $keyword and last if not grep { /^$keyword$/ } @valid_keywords;
-  }
+if ($arguments =~ m/([\$`\|{}"'#@=?\[\]])/ or $arguments =~ m/(~~)/) { $invalid = $1; }
+else {
+    while ($arguments =~ /([a-zA-Z0-9]+)/g) {
+        my $keyword = $1;
+        next if $keyword =~ m/^[0-9]+$/;
+        $invalid = $keyword and last if not grep { /^$keyword$/ } @valid_keywords;
+    }
 }
 
 if ($invalid) {
-  print "Illegal symbol '$invalid' in equation\n";
-  exit 1;
+    print "Illegal symbol '$invalid' in equation\n";
+    exit 1;
 }
 
 $response = eval("use POSIX qw/ceil floor/; use Math::Trig; use Math::Complex;" . $arguments);
 
 if ($@) {
-  my $error = $@;
-  $error =~ s/[\n\r]+//g;
-  $error =~ s/ at \(eval \d+\) line \d+.//;
-  $error =~ s/ at EOF$//;
-  $error =~ s/Died at .*//;
-  print $error;
-  exit 1;
+    my $error = $@;
+    $error =~ s/[\n\r]+//g;
+    $error =~ s/ at \(eval \d+\) line \d+.//;
+    $error =~ s/ at EOF$//;
+    $error =~ s/Died at .*//;
+    print $error;
+    exit 1;
 }
 
 if (@conversion) {
-  my $result = eval { convert($response, $conversion[0], $conversion[1]); };
-  if ($@) {
-    print "Unknown conversion from $conversion[0] to $conversion[1]. Units are case-sensitive (Hz, not hz).\n";
-    exit 1;
-  }
-  $response = "$result $conversion[1]";
+    my $result = eval { convert($response, $conversion[0], $conversion[1]); };
+    if ($@) {
+        print "Unknown conversion from $conversion[0] to $conversion[1]. Units are case-sensitive (Hz, not hz).\n";
+        exit 1;
+    }
+    $response = "$result $conversion[1]";
 }
 
 print "$orig_arguments = $response\n";
diff --git a/modules/nickometer.pl b/modules/nickometer.pl
index 757b7186..330c997d 100755
--- a/modules/nickometer.pl
+++ b/modules/nickometer.pl
@@ -15,72 +15,64 @@ use Math::Trig;
 
 use vars qw($VERSION $score $verbose);
 
-$VERSION = '$Revision: 1.3 $';	# '
+$VERSION = '$Revision: 1.3 $';    # '
 $VERSION =~ s/^.*?([\d.]+).*?$/$1/;
 
 sub nickometer ($) {
-  local $_ = shift;
+    local $_ = shift;
 
-  local $score = 0;
+    local $score = 0;
 
-  # Deal with special cases (precede with \ to prevent de-k3wlt0k)
-  my %special_cost = (
-		      '_'			=> 50,
-		      '69'			=> 500,
-		      'dea?th'			=> 500,
-		      'dark'			=> 400,
-		      'n[i1]ght'		=> 300,
-		      'n[i1]te'			=> 500,
-		      'fuck'			=> 500,
-		      'sh[i1]t'			=> 500,
-		      'coo[l1]'			=> 500,
-		      'kew[l1]'			=> 500,
-          'sw[a4]g'     => 500,
-		      'lame'			=> 500,
-		      'dood'			=> 500,
-		      'dude'			=> 500,
-		      '[l1](oo?|u)[sz]er'	=> 500,
-		      '[l1](ee|33)[t7]'		=> 500,
-		      'e[l1]ite'		=> 500,
-		      '[l1]ord'			=> 500,
-		      's[e3]xy'			=> 700,
-		      'h[o0]rny'		=> 700,
-		      'pr[o0]n'			=> 1000,
-		      'w[4a]r[e3]z'		=> 1000,
-		      'xx'			=> 450,
-		     );
+    # Deal with special cases (precede with \ to prevent de-k3wlt0k)
+    my %special_cost = (
+        '_'                 => 50,
+        '69'                => 500,
+        'dea?th'            => 500,
+        'dark'              => 400,
+        'n[i1]ght'          => 300,
+        'n[i1]te'           => 500,
+        'fuck'              => 500,
+        'sh[i1]t'           => 500,
+        'coo[l1]'           => 500,
+        'kew[l1]'           => 500,
+        'sw[a4]g'           => 500,
+        'lame'              => 500,
+        'dood'              => 500,
+        'dude'              => 500,
+        '[l1](oo?|u)[sz]er' => 500,
+        '[l1](ee|33)[t7]'   => 500,
+        'e[l1]ite'          => 500,
+        '[l1]ord'           => 500,
+        's[e3]xy'           => 700,
+        'h[o0]rny'          => 700,
+        'pr[o0]n'           => 1000,
+        'w[4a]r[e3]z'       => 1000,
+        'xx'                => 450,
+    );
 
-  foreach my $special (keys %special_cost) {
-    my $special_pattern = $special;
-    my $raw = ($special_pattern =~ s/^\\//);
-    my $nick = $_;
-    unless ($raw) {
-      $nick =~ tr/023457+8/ozeasttb/;
+    foreach my $special (keys %special_cost) {
+        my $special_pattern = $special;
+        my $raw             = ($special_pattern =~ s/^\\//);
+        my $nick            = $_;
+        unless ($raw) { $nick =~ tr/023457+8/ozeasttb/; }
+        while ($nick =~ /$special_pattern/ig) { &punish($special_cost{$special}, "matched special case /$special_pattern/") }
     }
-    while ($nick =~ /$special_pattern/ig) {
-      &punish($special_cost{$special}, "matched special case /$special_pattern/")
-    }
-  }
 
-  if ($_ =~ m/^.$/) {
-    &punish(1000, "single letter nick");
-  }
+    if ($_ =~ m/^.$/) { &punish(1000, "single letter nick"); }
 
-  while (m/[A-Z]([^A-Z]+)\b/g) {
-    &punish(250, "length 1 between capitals") if length $1 == 1;
-  }
+    while (m/[A-Z]([^A-Z]+)\b/g) { &punish(250, "length 1 between capitals") if length $1 == 1; }
 
-  # Allow Perl referencing
-  s/^\\([A-Za-z])/$1/;
+    # Allow Perl referencing
+    s/^\\([A-Za-z])/$1/;
 
-  # Keep me safe from Pudge ;-)
-  s/\^(pudge)/$1/i;
+    # Keep me safe from Pudge ;-)
+    s/\^(pudge)/$1/i;
 
-  # C-- ain't so bad either
-  s/^C--$/C/;
+    # C-- ain't so bad either
+    s/^C--$/C/;
 
-  # Punish consecutive non-alphas
-  s/([^A-Za-z0-9]{2,})
+    # Punish consecutive non-alphas
+    s/([^A-Za-z0-9]{2,})
    /my $consecutive = length($1);
     &punish(&slow_pow(10, $consecutive),
 	    "$consecutive total consecutive non-alphas")
@@ -88,155 +80,143 @@ sub nickometer ($) {
     $1
    /egx;
 
-  # Remove balanced brackets and punish for unmatched
-  while (s/^([^()]*)   (\() (.*) (\)) ([^()]*)   $/$1$3$5/x ||
-	 s/^([^{}]*)   (\{) (.*) (\}) ([^{}]*)   $/$1$3$5/x ||
-	 s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x)
-  {
-    print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
-  }
-  my $parentheses = tr/(){}[]/(){}[]/;
-  &punish(&slow_pow(10, $parentheses),
-	  "$parentheses unmatched " .
-	    ($parentheses == 1 ? 'parenthesis' : 'parentheses'))
-    if $parentheses;
+    # Remove balanced brackets and punish for unmatched
+    while (s/^([^()]*)   (\() (.*) (\)) ([^()]*)   $/$1$3$5/x || s/^([^{}]*)   (\{) (.*) (\}) ([^{}]*)   $/$1$3$5/x || s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x) {
+        print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
+    }
+    my $parentheses = tr/(){}[]/(){}[]/;
+    &punish(
+        &slow_pow(10, $parentheses),
+        "$parentheses unmatched " . ($parentheses == 1 ? 'parenthesis' : 'parentheses')
+    ) if $parentheses;
 
-  # Punish k3wlt0k
-  my @k3wlt0k_weights = (5, 5, 2, 5, 2, 3, 1, 2, 2, 2);
-  for my $digit (0 .. 9) {
-    my $occurrences = s/$digit/$digit/g || 0;
-    &punish($k3wlt0k_weights[$digit] * $occurrences * 30,
-	    $occurrences . ' ' .
-	      (($occurrences == 1) ? 'occurrence' : 'occurrences') .
-	      " of $digit")
-      if $occurrences;
-  }
+    # Punish k3wlt0k
+    my @k3wlt0k_weights = (5, 5, 2, 5, 2, 3, 1, 2, 2, 2);
+    for my $digit (0 .. 9) {
+        my $occurrences = s/$digit/$digit/g || 0;
+        &punish(
+            $k3wlt0k_weights[$digit] * $occurrences * 30,
+            $occurrences . ' ' . (($occurrences == 1) ? 'occurrence' : 'occurrences') . " of $digit"
+        ) if $occurrences;
+    }
 
-  # An alpha caps is not lame in middle or at end, provided the first
-  # alpha is caps.
-  my $orig_case = $_;
-  s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
+    # An alpha caps is not lame in middle or at end, provided the first
+    # alpha is caps.
+    my $orig_case = $_;
+    s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
 
-  # A caps first alpha is sometimes not lame
-  s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
+    # A caps first alpha is sometimes not lame
+    s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
 
-  # Punish uppercase to lowercase shifts and vice-versa, modulo
-  # exceptions above
-  my $case_shifts = &case_shifts($orig_case);
-  &punish(&slow_pow(5, $case_shifts),
-	  $case_shifts . ' case ' .
-	    (($case_shifts == 1) ? 'shift' : 'shifts'))
-    if ($case_shifts > 1 && /[A-Z]/);
+    # Punish uppercase to lowercase shifts and vice-versa, modulo
+    # exceptions above
+    my $case_shifts = &case_shifts($orig_case);
+    &punish(
+        &slow_pow(5, $case_shifts),
+        $case_shifts . ' case ' . (($case_shifts == 1) ? 'shift' : 'shifts')
+    ) if ($case_shifts > 1 && /[A-Z]/);
 
-  # Punish lame endings (TorgoX, WraithX et al. might kill me for this :-)
-  &punish(50, 'last alpha lame') if $orig_case =~ /[XZ][^a-zA-Z]*$/;
+    # Punish lame endings (TorgoX, WraithX et al. might kill me for this :-)
+    &punish(50, 'last alpha lame') if $orig_case =~ /[XZ][^a-zA-Z]*$/;
 
-  # Punish letter to numeric shifts and vice-versa
-  my $number_shifts = &number_shifts($_);
-  &punish(&slow_pow(9, $number_shifts),
-	  $number_shifts . ' letter/number ' .
-	    (($number_shifts == 1) ? 'shift' : 'shifts'))
-    if $number_shifts > 1;
+    # Punish letter to numeric shifts and vice-versa
+    my $number_shifts = &number_shifts($_);
+    &punish(
+        &slow_pow(9, $number_shifts),
+        $number_shifts . ' letter/number ' . (($number_shifts == 1) ? 'shift' : 'shifts')
+    ) if $number_shifts > 1;
 
-  # Punish extraneous caps
-  my $caps = tr/A-Z/A-Z/;
-  &punish(&slow_pow(7, $caps), "$caps extraneous caps") if $caps;
+    # Punish extraneous caps
+    my $caps = tr/A-Z/A-Z/;
+    &punish(&slow_pow(7, $caps), "$caps extraneous caps") if $caps;
 
-  # Now punish anything that's left
-  my $remains = $_;
-  $remains =~ tr/a-zA-Z0-9//d;
-  my $remains_length = length($remains);
+    # Now punish anything that's left
+    my $remains = $_;
+    $remains =~ tr/a-zA-Z0-9//d;
+    my $remains_length = length($remains);
 
-  &punish(150 * $remains_length + &slow_pow(9, $remains_length),
-	  $remains_length . ' extraneous ' .
-	    (($remains_length == 1) ? 'symbol' : 'symbols'))
-    if $remains;
+    &punish(
+        150 * $remains_length + &slow_pow(9, $remains_length),
+        $remains_length . ' extraneous ' . (($remains_length == 1) ? 'symbol' : 'symbols')
+    ) if $remains;
 
-  print "\nRaw lameness score is $score\n" if $verbose;
+    print "\nRaw lameness score is $score\n" if $verbose;
 
-  # Use an appropriate function to map [0, +inf) to [0, 100)
-  my $percentage = 100 *
-                     (1 + tanh(($score-400)/400)) *
-                     (1 - 1/(1+$score/5)) / 2;
+    # Use an appropriate function to map [0, +inf) to [0, 100)
+    my $percentage = 100 * (1 + tanh(($score - 400) / 400)) * (1 - 1 / (1 + $score / 5)) / 2;
 
-  my $digits = 2 * (2 - &round_up(log(100 - $percentage) / log(10)));
+    my $digits = 2 * (2 - &round_up(log(100 - $percentage) / log(10)));
 
-  return sprintf "%.${digits}f", $percentage;
+    return sprintf "%.${digits}f", $percentage;
 }
 
 sub case_shifts ($) {
-  # This is a neat trick suggested by freeside.  Thanks freeside!
 
-  my $shifts = shift;
+    # This is a neat trick suggested by freeside.  Thanks freeside!
 
-  $shifts =~ tr/A-Za-z//cd;
-  $shifts =~ tr/A-Z/U/s;
-  $shifts =~ tr/a-z/l/s;
+    my $shifts = shift;
 
-  return length($shifts) - 1;
+    $shifts =~ tr/A-Za-z//cd;
+    $shifts =~ tr/A-Z/U/s;
+    $shifts =~ tr/a-z/l/s;
+
+    return length($shifts) - 1;
 }
 
 sub number_shifts ($) {
-  my $shifts = shift;
+    my $shifts = shift;
 
-  $shifts =~ tr/A-Za-z0-9//cd;
-  $shifts =~ tr/A-Za-z/l/s;
-  $shifts =~ tr/0-9/n/s;
+    $shifts =~ tr/A-Za-z0-9//cd;
+    $shifts =~ tr/A-Za-z/l/s;
+    $shifts =~ tr/0-9/n/s;
 
-  return length($shifts) - 1;
+    return length($shifts) - 1;
 }
 
 sub slow_pow ($$) {
-  my ($x, $y) = @_;
+    my ($x, $y) = @_;
 
-  return $x ** &slow_exponent($y);
+    return $x**&slow_exponent($y);
 }
 
 sub slow_exponent ($) {
-  my $x = shift;
+    my $x = shift;
 
-  return 1.3 * $x * (1 - atan($x/6) *2/pi);
+    return 1.3 * $x * (1 - atan($x / 6) * 2 / pi);
 }
 
 sub round_up ($) {
-  my $float = shift;
+    my $float = shift;
 
-  return int($float) + ((int($float) == $float) ? 0 : 1);
+    return int($float) + ((int($float) == $float) ? 0 : 1);
 }
 
 sub punish ($$) {
-  my ($damage, $reason) = @_;
+    my ($damage, $reason) = @_;
 
-  return unless $damage;
+    return unless $damage;
 
-  $score += $damage;
-  print "$damage lameness points awarded: $reason\n" if $verbose;
+    $score += $damage;
+    print "$damage lameness points awarded: $reason\n" if $verbose;
 }
 
 my $nick = $ARGV[0];
 
-if ($nick =~ s/ verbose$//) {
-  $verbose = 1;
-}
+if ($nick =~ s/ verbose$//) { $verbose = 1; }
 
-if ($ARGV[1] and $ARGV[1] eq 'verbose') {
-  $verbose = 1;
-}
+if ($ARGV[1] and $ARGV[1] eq 'verbose') { $verbose = 1; }
 
 if (not defined $nick) {
-  print "Usage: nickometer <nick>\n";
-  exit 1;
+    print "Usage: nickometer <nick>\n";
+    exit 1;
 }
 
 if ($nick =~ m/pragma/) {
-  print "$nick is a really awesome nick!";
-  exit 0;
+    print "$nick is a really awesome nick!";
+    exit 0;
 }
 
 my $percentage = nickometer($nick);
 
-if ($percentage > 0) {
-  print "$nick is $percentage% lame.\n";
-} else {
-  print "$nick isn't lame.\n";
-}
+if   ($percentage > 0) { print "$nick is $percentage% lame.\n"; }
+else                   { print "$nick isn't lame.\n"; }
diff --git a/modules/prototype.pl b/modules/prototype.pl
index 7a5fd21e..230ef421 100755
--- a/modules/prototype.pl
+++ b/modules/prototype.pl
@@ -12,22 +12,21 @@ use LWP::Simple;
 my ($result, $manpage, $section, $text, $name, $includes, $prototype, $description);
 
 if ($#ARGV < 0) {
-  print "Which command would you like information about?\n";
-  die;
+    print "Which command would you like information about?\n";
+    die;
 }
 
 $manpage = join("+", @ARGV);
 $section = "3";
 
 if ($manpage =~ m/([0-9]+)\+(.*)/) {
-  $section = $1;
-  $manpage = $2;
+    $section = $1;
+    $manpage = $2;
 }
 
-if (!($section == 2 || $section == 3))
-{
-  print "I'm only interested in displaying information about sections 2 or 3.\n";
-  exit 0;
+if (!($section == 2 || $section == 3)) {
+    print "I'm only interested in displaying information about sections 2 or 3.\n";
+    exit 0;
 }
 
 $text = get("http://node1.yo-linux.com/cgi-bin/man2html?cgi_command=$manpage&cgi_section=$section&cgi_keyword=m");
@@ -35,32 +34,29 @@ $text = get("http://node1.yo-linux.com/cgi-bin/man2html?cgi_command=$manpage&cgi
 $manpage =~ s/\+/ /g;
 
 if ($text =~ m/No.*?entry\sfor(.*)/i) {
-  print "No entry for$1";
-  die;
+    print "No entry for$1";
+    die;
 }
 
 #$text =~ m/<\/A>.*?NAME\n/gs;
 
-if ($text =~ m/(.*?)SYNOPSIS/gsi) {
-  $name = $1;
-}
+if ($text =~ m/(.*?)SYNOPSIS/gsi) { $name = $1; }
 
 my $i = 0;
 while ($text =~ m/#include <(.*?)>/gsi) {
-  $includes .= ", " if ($i > 0);
-  $includes .= "$1";
-  $i++;
+    $includes .= ", " if ($i > 0);
+    $includes .= "$1";
+    $i++;
 }
 
-$prototype = "$1 $2$manpage($3);"
-  if ($text =~ m/SYNOPSIS.*^\s+(.*?)\s+(\*?)$manpage\s*\((.*?)\)\;?\n.*DESC/ms);
+$prototype = "$1 $2$manpage($3);" if ($text =~ m/SYNOPSIS.*^\s+(.*?)\s+(\*?)$manpage\s*\((.*?)\)\;?\n.*DESC/ms);
 
 $description = "$manpage $1" if ($text =~ m/DESCRIPTION.*?$manpage(.*?)\./gsi);
 $description =~ s/\-\s+//g;
 
 if (not defined $prototype) {
-  print "No prototype found for $manpage";
-  exit 0;
+    print "No prototype found for $manpage";
+    exit 0;
 }
 
 $result = "Includes: $includes - " if (defined $includes);
diff --git a/modules/qalc.pl b/modules/qalc.pl
index 88cee4f3..4213e368 100755
--- a/modules/qalc.pl
+++ b/modules/qalc.pl
@@ -10,8 +10,8 @@ use strict;
 my $args = join ' ', @ARGV;
 
 if (not length $args) {
-  print "Usage: qalc <expression>\n";
-  exit;
+    print "Usage: qalc <expression>\n";
+    exit;
 }
 
 my $result = `ulimit -t 2; qalc '$args'`;
@@ -20,4 +20,5 @@ $result =~ s/^.*approx.\s+//;
 $result =~ s/^.*=\s+//;
 
 print "$args = $result\n";
+
 # print "$result\n";
diff --git a/modules/random_quote.pl b/modules/random_quote.pl
index 8407d652..52241634 100755
--- a/modules/random_quote.pl
+++ b/modules/random_quote.pl
@@ -11,15 +11,16 @@ use LWP::UserAgent::WithCache;
 my ($text, $t);
 
 my %cache_opt = (
-  'namespace' => 'lwp-cache',
-  'cache_root' => File::Spec->catfile(File::HomeDir->my_home, '.lwpcache'),
-  'default_expires_in' => 600 * 6 * 24 );
+    'namespace'          => 'lwp-cache',
+    'cache_root'         => File::Spec->catfile(File::HomeDir->my_home, '.lwpcache'),
+    'default_expires_in' => 600 * 6 * 24
+);
 my $ua = LWP::UserAgent::WithCache->new(\%cache_opt);
 
 $ua->agent("Mozilla/5.0");
 
 my $response;
-my $page = 1;
+my $page  = 1;
 my $pages = undef;
 my @quotes;
 
@@ -27,91 +28,91 @@ my @quotes;
 #print "$#quotes\n";
 
 while (1) {
-  if ($#ARGV < 0) {
-    my %post = ( 'number' => '4', 'collection[]' => 'mgm', 'collection[]' => 'motivate' );
-    $response = $ua->post("http://www.quotationspage.com/random.php3", \%post);
-  } else {
-    my $arguments = join('+', @ARGV);
-    my $author = "";
+    if ($#ARGV < 0) {
+        my %post = ('number' => '4', 'collection[]' => 'mgm', 'collection[]' => 'motivate');
+        $response = $ua->post("http://www.quotationspage.com/random.php3", \%post);
+    } else {
+        my $arguments = join('+', @ARGV);
+        my $author    = "";
 
-    $arguments =~ s/\$nick/me/gi;
-    $arguments =~ s/\s/+/g;
+        $arguments =~ s/\$nick/me/gi;
+        $arguments =~ s/\s/+/g;
 
-    if ($arguments =~ m/\-\-author[\s\+]+(.*)/i) {
-      $author = $1;
-      $arguments =~ s/\-\-author[\s\+]+(.*)//i;
+        if ($arguments =~ m/\-\-author[\s\+]+(.*)/i) {
+            $author = $1;
+            $arguments =~ s/\-\-author[\s\+]+(.*)//i;
+        }
+
+        # print "search: [$arguments]; author: [$author]\n";
+        if ((length $arguments < 3) && ($author eq "")) {
+            print "Quote search parameter too small.\n";
+            exit;
+        }
+
+        if ((length $author > 0) && (length $author < 3)) {
+            print "Quote author parameter too small.\n";
+            exit;
+        }
+
+        $arguments =~ s/\++$//;
+        $author    =~ s/\++$//;
+
+        #    print "http://www.quotationspage.com/search.php3?Search=$arguments&startsearch=Search&Author=$author&C=mgm&C=motivate&C=classic&C=coles&C=poorc&C=lindsly&C=net&C=devils&C=contrib&page=$page\n";
+        $response = $ua->get(
+            "http://www.quotationspage.com/search.php3?Search=$arguments&startsearch=Search&Author=$author&C=mgm&C=motivate&C=classic&C=coles&C=poorc&C=lindsly&C=net&C=contrib&page=$page"
+        );
     }
 
-    # print "search: [$arguments]; author: [$author]\n";
-    if ((length $arguments < 3) && ($author eq "")) {
-      print "Quote search parameter too small.\n";
-      exit;
+    if (not $response->is_success) {
+        print "Couldn't get quote information.\n";
+        die;
     }
 
-    if ((length $author > 0) && (length $author < 3)) {
-      print "Quote author parameter too small.\n";
-      exit;
+    $text = $response->content;
+
+    while ($text =~ m/<dt class="quote"><a.*?>(.*?)<\/a>.*?<dd class="author"><div.*?><a.*?>.*?<b>(.*?)<\/b>/g) {
+        $t = "\"$1\" -- $2.";
+        push @quotes, $t;
+
+        #print "Added '$t'\n";
+        #print "$#quotes\n";
+        last if ($#ARGV < 0);
     }
 
-    $arguments =~ s/\++$//;
-    $author =~ s/\++$//;
+    if ($text =~ m/Page \d+ of (\d+)/) {
+        $pages = $1;
+        $page++;
+        last if $page > $pages;
 
-#    print "http://www.quotationspage.com/search.php3?Search=$arguments&startsearch=Search&Author=$author&C=mgm&C=motivate&C=classic&C=coles&C=poorc&C=lindsly&C=net&C=devils&C=contrib&page=$page\n";
-    $response = $ua->get("http://www.quotationspage.com/search.php3?Search=$arguments&startsearch=Search&Author=$author&C=mgm&C=motivate&C=classic&C=coles&C=poorc&C=lindsly&C=net&C=contrib&page=$page");
-  }
+        # print "Pages: $pages; fetching page $page\n";
+    } else {
+        last;
+    }
 
-  if (not $response->is_success)
-  {
-    print "Couldn't get quote information.\n";
-    die;
-  }
+    if ($#quotes < 0) {
+        print "No results found.\n";
+        exit;
+    }
 
-  $text = $response->content;
-
-  while ($text =~ m/<dt class="quote"><a.*?>(.*?)<\/a>.*?<dd class="author"><div.*?><a.*?>.*?<b>(.*?)<\/b>/g) {
-    $t = "\"$1\" -- $2.";
-    push @quotes, $t;
-    #print "Added '$t'\n";
-    #print "$#quotes\n";
     last if ($#ARGV < 0);
-  }
-
-  if ($text =~ m/Page \d+ of (\d+)/) {
-    $pages = $1;
-    $page++;
-    last if $page > $pages;
-    # print "Pages: $pages; fetching page $page\n";
-  } else {
-    last;
-  }
-
-  if ($#quotes < 0) {
-    print "No results found.\n";
-    exit;
-  }
-
-  last if ($#ARGV < 0);
 }
 
 # print "Total quotes: ", $#quotes + 1, "\n";
 
 if ($#quotes < 0) {
-  print "No results found.\n";
-  exit;
+    print "No results found.\n";
+    exit;
 }
 
-
 $t = $quotes[int rand($#quotes + 1)];
 
 if ($#ARGV > -1) {
-  if ($#quotes + 1 > 1) {
-    $t = "" . ($#quotes + 1) . " matching quote" . (($#quotes + 1) != 1 ? "s" : "") . " found. $t";
-  }
+    if ($#quotes + 1 > 1) { $t = "" . ($#quotes + 1) . " matching quote" . (($#quotes + 1) != 1 ? "s" : "") . " found. $t"; }
 }
 
-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;
diff --git a/modules/rpn.pl b/modules/rpn.pl
index 5af5bde1..23f86168 100755
--- a/modules/rpn.pl
+++ b/modules/rpn.pl
@@ -1,44 +1,39 @@
 #!/usr/bin/perl -sw
 use strict;
-use List::Util qw[ reduce ]; $a=$b;
+use List::Util qw[ reduce ]; $a = $b;
 
 our $XLATE ||= 0;
 
 sub rpn2exp {
-  local $SIG{__WARN__} = sub {
-    print "Malformed arguments.\n";
-    exit 1;
-  };
-  my %tops = map{ $_ => undef } qw[ % MOD + ADD * MULT / DIV ** POW - SUB ];
-  my @stack;
-  my $expr;
-  while ( @_ ) {
-    my $item = shift @_;
-    push( @stack, $item ), next
-    unless exists $tops{ $item } or $item =~ m[\(\)$];
-    if ( exists $tops{ $item } ) {
-      my $arg2 = pop @stack;
-      my $arg1 = pop @stack;
-      push @stack, "($arg1 $item $arg2)";
-    }
-    elsif ( my( $func ) = $item =~ m[^(.*)\(\)$] ) {
-      my $args = pop @stack;
-      if ($args > 4) {
-        print "Too many function arguments.\n";
+    local $SIG{__WARN__} = sub {
+        print "Malformed arguments.\n";
         exit 1;
-      }
-      my @args = map{ pop @stack } 1 .. $args;
-      push @stack, $func . '(' . join( ', ', reverse @args ) . ')';
+    };
+    my %tops = map { $_ => undef } qw[ % MOD + ADD * MULT / DIV ** POW - SUB ];
+    my @stack;
+    my $expr;
+    while (@_) {
+        my $item = shift @_;
+        push(@stack, $item), next unless exists $tops{$item} or $item =~ m[\(\)$];
+        if (exists $tops{$item}) {
+            my $arg2 = pop @stack;
+            my $arg1 = pop @stack;
+            push @stack, "($arg1 $item $arg2)";
+        } elsif (my ($func) = $item =~ m[^(.*)\(\)$]) {
+            my $args = pop @stack;
+            if ($args > 4) {
+                print "Too many function arguments.\n";
+                exit 1;
+            }
+            my @args = map { pop @stack } 1 .. $args;
+            push @stack, $func . '(' . join(', ', reverse @args) . ')';
+        }
     }
-  }
-  return "@stack";
+    return "@stack";
 }
 
 sub nestedOk {
-  index( $_[ 0 ], '(' ) <= index( $_[ 0 ], ')' ) and
-  0 == reduce{
-    $a + ( $b eq '(' ) - ( $b eq ')' )
-  } 0, split'[^()]*', $_[ 0 ]
+    index($_[0], '(') <= index($_[0], ')') and 0 == reduce { $a + ($b eq '(') - ($b eq ')') } 0, split '[^()]*', $_[0];
 }
 
 my $re_var   = qr[ [a-zA-Z]\w* ]x;
@@ -47,73 +42,71 @@ my $re_func  = qr[ $re_var $re_subex ]x;
 my $re_num   = qr[ -? \d+ (?: \. \d+ )? (?: [Ee] [+-]? \d+ )? ]x;
 my $re_term  = qr[ $re_num | $re_func | $re_subex | $re_var ]x;
 my $re_op    = qr[\*\*|[,*%+/^-]];
-my %ops = ( qw[ % MOD + ADD * MULT / DIV ** POW - SUB ] );
+my %ops      = (qw[ % MOD + ADD * MULT / DIV ** POW - SUB ]);
 
 my @varargs;
+
 sub exp2rpn {
-  my( $exp, $aStack, $aBits ) = @_;
-  print "Unbalanced parens: '$exp'" and exit 1 unless nestedOk $exp;
-  if ( $exp =~ m/^$re_term$/ and $exp !~ m/\{\d+\}/ ) {
-    push @$aStack, $exp;
-  }
-  else {{
-      my( $left, $op, $right, $rest ) = $exp =~ m[
+    my ($exp, $aStack, $aBits) = @_;
+    print "Unbalanced parens: '$exp'" and exit 1 unless nestedOk $exp;
+    if ($exp =~ m/^$re_term$/ and $exp !~ m/\{\d+\}/) { push @$aStack, $exp; }
+    else {
+        {
+            my ($left, $op, $right, $rest) = $exp =~ m[
         ^ (?: ( $re_term )? ( $re_op ) )? ( $re_term ) ( .* ) $
       ]x or print "malformed (sub)expression '$exp'" and exit 1;
-#{ no warnings; print "'$exp' => L'$left' O'$op' R'$right' >'$rest'"; }
 
-      $varargs[ -1 ]++ if $op and $op eq ',' and @varargs;
+            #{ no warnings; print "'$exp' => L'$left' O'$op' R'$right' >'$rest'"; }
 
-      for ( $left, $right ) {
-        next unless $_;
-        if ( my( $func, $subex ) = m[^ ( $re_var )? \{ ( \d+ ) \} $]x ) {
-          push @varargs, 1 if $func;
-          exp2rpn( $aBits->[ $subex ], $aStack, $aBits );
-          push @$aStack, pop( @varargs ), "$func()" if $func;
+            $varargs[-1]++ if $op and $op eq ',' and @varargs;
+
+            for ($left, $right) {
+                next unless $_;
+                if (my ($func, $subex) = m[^ ( $re_var )? \{ ( \d+ ) \} $]x) {
+                    push @varargs, 1 if $func;
+                    exp2rpn($aBits->[$subex], $aStack, $aBits);
+                    push @$aStack, pop(@varargs), "$func()" if $func;
+                } else {
+                    push(@$aStack, $_);
+                }
+            }
+            push @$aStack, $XLATE ? $ops{$op} : $op if $op and $op ne ',';
+            $exp = $rest, redo if $rest;
         }
-        else{
-          push( @$aStack, $_  );
-        }
-      }
-      push @$aStack, $XLATE ? $ops{ $op } : $op
-      if $op and $op ne ',';
-      $exp = $rest, redo if $rest;
-    }}
-  return $aStack;
+    }
+    return $aStack;
 }
 
 sub parseExp {
-  my( $exp ) = @_;
-  print "Unbalanced parens: '$exp'" and exit 1 unless nestedOk $exp;
-  $exp =~ s[\s+][]g;
-  my( $n, @bits )= ( 1, $exp );
+    my ($exp) = @_;
+    print "Unbalanced parens: '$exp'" and exit 1 unless nestedOk $exp;
+    $exp =~ s[\s+][]g;
+    my ($n, @bits) = (1, $exp);
 
-  for ( reverse @bits ) {
-    s/\( ( [^()]* )  \)/ push @bits, $1; "{${ \( $n++ ) }}"; /ex while m/[()]/;
-  }
+    for (reverse @bits) { s/\( ( [^()]* )  \)/ push @bits, $1; "{${ \( $n++ ) }}"; /ex while m/[()]/; }
 
-  s/([^,]+)(,?)/push @bits, $1; "{${ \( $n++ ) }}$2" /eg for reverse @bits;
+    s/([^,]+)(,?)/push @bits, $1; "{${ \( $n++ ) }}$2" /eg for reverse @bits;
 
-  for ( reverse @bits ) {
-    1 while s/( $re_term (?:\*\*)          $re_term )/ push @bits, $1; "{${ \( $n++ ) }}"; /gex;
-    1 while s/( $re_term (?:[*\/%])         $re_term )/ push @bits, $1; "{${ \( $n++ ) }}"; /gex;
-    1 while s/( $re_term (?:(?<![eE])[+-]) $re_term )/ push @bits, $1; "{${ \( $n++ ) }}"; /gex;
-  }
-  return @{ exp2rpn $bits[ 0 ], [], \@bits };
+    for (reverse @bits) {
+        1 while s/( $re_term (?:\*\*)          $re_term )/ push @bits, $1; "{${ \( $n++ ) }}"; /gex;
+        1 while s/( $re_term (?:[*\/%])         $re_term )/ push @bits, $1; "{${ \( $n++ ) }}"; /gex;
+        1 while s/( $re_term (?:(?<![eE])[+-]) $re_term )/ push @bits, $1; "{${ \( $n++ ) }}"; /gex;
+    }
+    return @{exp2rpn $bits[0], [], \@bits};
 }
 
 my $mode = shift @ARGV;
 my $args = join ' ', @ARGV;
 
 if (not $args) {
-  print "Missing arguments.\n";
-  exit 1;
+    print "Missing arguments.\n";
+    exit 1;
 }
 
 if ($mode eq 'rpn') {
-  my @rpn = parseExp $args;
-  print join(', ', @rpn), "\n";
+    my @rpn = parseExp $args;
+    print join(', ', @rpn), "\n";
 } else {
-  my $infix = rpn2exp split /\s*,\s*/, $args;
-  print "$infix\n";
+    my $infix = rpn2exp split /\s*,\s*/, $args;
+    print "$infix\n";
 }
diff --git a/modules/wikipedia.pl b/modules/wikipedia.pl
index 08cb2395..acde3439 100755
--- a/modules/wikipedia.pl
+++ b/modules/wikipedia.pl
@@ -12,31 +12,31 @@ use HTML::FormatText;
 my $term = join(' ', @ARGV);
 
 if (not $term) {
-  print "Usage: !wikipedia <term>\n";
-  exit;
+    print "Usage: !wikipedia <term>\n";
+    exit;
 }
 
-my $wiki = WWW::Wikipedia->new(language => 'en');
+my $wiki  = WWW::Wikipedia->new(language => 'en');
 my $entry = $wiki->search($term);
 
 if ($entry) {
     my $text = $entry->text();
 
     if ($text) {
-      $text =~ s/\{\{.*?}}//msg;
-      $text =~ s/\[\[//g;
-      $text =~ s/\]\]//g;
-      $text =~ s/<ref>.*?<\/ref>//g;
-      $text =~ s/__[A-Z]+__//g;
-      $text =~ s/\s+\(\)//msg;
-      $text = HTML::FormatText->new->format(parse_html($text));
-      print $text;
+        $text =~ s/\{\{.*?}}//msg;
+        $text =~ s/\[\[//g;
+        $text =~ s/\]\]//g;
+        $text =~ s/<ref>.*?<\/ref>//g;
+        $text =~ s/__[A-Z]+__//g;
+        $text =~ s/\s+\(\)//msg;
+        $text = HTML::FormatText->new->format(parse_html($text));
+        print $text;
     } else {
         print "Specific entry not found, see also: ";
         my $semi = "";
         foreach ($entry->related()) { print "$semi$_"; $semi = "; "; }
     }
 } else {
-  print qq("$term" not found in Wikipedia\n)
+    print qq("$term" not found in Wikipedia\n);
 }
 
diff --git a/pbot b/pbot
index abee7058..b8141e9f 100755
--- a/pbot
+++ b/pbot
@@ -7,17 +7,17 @@
 # bothome is automatically set by this script, do not modify
 my $bothome;
 BEGIN {
-  use File::Basename;
-  $bothome = -l __FILE__ ? dirname readlink __FILE__ : dirname __FILE__;
-  unshift @INC, $bothome;
+    use File::Basename;
+    $bothome = -l __FILE__ ? dirname readlink __FILE__ : dirname __FILE__;
+    unshift @INC, $bothome;
 }
 
 # configuration is overridden via command-line arguments, do not modify
 # see doc/QuickStart.md
 my %config = (
-  data_dir   => "$bothome/data",
-  module_dir => "$bothome/modules",
-  plugin_dir => "$bothome/Plugins",
+    data_dir   => "$bothome/data",
+    module_dir => "$bothome/modules",
+    plugin_dir => "$bothome/Plugins",
 );
 
 use PBot::PBot;