view release on metacpan or  search on metacpan

script/kgb-bot  view on Meta::CPAN

        unless ref $params
        and ref $params eq "HASH"
        and $params->{Array}
        and ref $params->{Array}
        and ref $params->{Array} eq "ARRAY";

    my $proto_ver;
    if ( @{ $params->{Array} } == 6 ) {
        $proto_ver = 0;
    }
    else {
        $proto_ver = shift @{ $params->{Array} };
    }

    throw Error::Simple(
        sprintf(
            "Protocol version %s not welcomed\n", $proto_ver // '<undef>'
        )
        )
        unless defined($proto_ver)
        and $KGB::supported_protos{$proto_ver}
        and $proto_ver >= $KGB::config->{min_protocol_ver};

    throw Error::Simple("Rate limit enforced\n")
        if $KGB::config->{queue_limit}
        and $KGB::IRC::irc_object
        and $KGB::config->{queue_limit} < $KGB::IRC::irc_object->send_queue;

    if ( $proto_ver == 0 ) {
        return do_commit_v0( $kernel, @{ $params->{Array} } );
    }
    if ( $proto_ver == 1 ) {
        return do_commit_v1( $kernel, @{ $params->{Array} } );
    }
    if ( $proto_ver == 2 ) {
        return do_commit_v2( $kernel, @{ $params->{Array} } );
    }
    if ( $proto_ver == 3 ) {
        return do_commit_v3( $kernel, @{ $params->{Array} } );
    }
    throw Error::Simple("Invalid protocol version ($proto_ver)\n");
}

package KGB::IRC;

use strict;
use warnings;

use App::KGB;
use Digest::MD5 qw(md5_hex);
use Monkey::Patch;
use POE;
use POE::Component::IRC::Common qw( parse_user matches_mask );
use POE::Component::IRC::Constants qw( MSG_PRI MSG_TEXT PRI_HIGH );
use Schedule::RateLimiter;
use Storable qw(dclone);

our %current = ();
our $irc_object;
our $autoresponse_limitter
    = Schedule::RateLimiter->new( iterations => 5, seconds => 30,
    block => 0 );

# Monkey patch to avoid delaying high priority commands when flood protection
# is enabled.
sub _sl_delayed {
    my $orig_func = shift;
    my $self = $_[OBJECT];
    return if !defined $self->{socket};

    while (@{ $self->{send_queue} } &&
        $self->{send_queue}[0][MSG_PRI] <= PRI_HIGH)
    {
        my $arg = (shift @{$self->{send_queue}})->[MSG_TEXT];
        warn ">>> $arg\n" if $self->{debug};
        $self->send_event(irc_raw_out => $arg) if $self->{raw};
        $self->{socket}->put($arg);
    }
    return $orig_func->(@_);
}
my $patch = Monkey::Patch::patch_package('POE::Component::IRC', 'sl_delayed',
    \&_sl_delayed);

# Handles the connection, disconnection and real-time configuration changes WRT
# IRC servers and channels
sub _irc_reconnect {
    my ( $kernel, $session ) = @_[ KERNEL, SESSION ];
    my ( @to_start, @to_stop, @to_restart );

    KGB->debug("_irc_reconnect called, re-sync network configuration.");
    foreach my $net ( keys %current ) {
        next unless ( defined( $current{$net} ) );
        my ( $new, $old )
            = ( $KGB::config->{networks}{$net}, $current{$net} );
        if ( !$new ) {
            push @to_stop, $net;
        }
        elsif ($new->{nick} ne $old->{nick}
            or $new->{ircname}  ne $old->{ircname}
            or $new->{username} ne $old->{username}
            or ( $new->{password} || "" ) ne ( $old->{password} || "" )
            or ( $new->{nickserv_password} || "" ) ne
            ( $old->{nickserv_password} || "" )
            or $new->{server} ne $old->{server}
            or $new->{port}   ne $old->{port}
            or ( $new->{use_ssl} // '' ) ne ( $old->{use_ssl} // '' )
    )
        {
            push @to_restart, $net;
        }
        else {
            # TODO: this doesn't account for secret changes
            # perhaps it needs to part and re-join a channel when
            # its secret is changed?
            my ( %newchan, %oldchan, %allchan );
            %newchan = %{ $new->{channels} };
            %oldchan = %{ $old->{channels} };
            %allchan = ( %newchan, %oldchan );
            foreach my $chan ( sort keys %allchan ) {
                if ( exists $newchan{$chan} and not exists $oldchan{$chan} ) {
                    KGB->out("Joining $chan...\n");