POE::Component::IRC::Plugin::ISupport - A PoCo-IRC plugin that handles server

POE-Component-IRC documentation Contained in the POE-Component-IRC distribution.

Index

Code Index:

NAME

Top

POE::Component::IRC::Plugin::ISupport - A PoCo-IRC plugin that handles server capabilities

DESCRIPTION

Top

This handles the irc_005 messages that come from the server. They define the capabilities support by the server.

METHODS

Top

new

Takes no arguments.

Returns a plugin object suitable for feeding to POE::Component::IRC's plugin_add method.

isupport

Takes one argument. the server capability to query. Returns a false value on failure or a value representing the applicable capability. A full list of capabilities is available at http://www.irc.org/tech_docs/005.html.

isupport_dump_keys

Takes no arguments, returns a list of the available server capabilities, which can be used with isupport.

INPUT

Top

This module handles the following PoCo-IRC signals:

irc_005 (RPL_ISUPPORT or RPL_PROTOCTL)

Denotes the capabilities of the server.

all

Once the next signal is received that is greater than irc_005, it emits an irc_isupport signal.

OUTPUT EVENTS

Top

irc_isupport

Emitted by: the first signal received after irc_005

ARG0 will be the plugin object itself for ease of use.

This is emitted when the support report has finished.

AUTHOR

Top

Jeff japhy Pinyan, japhy@perlmonk.org

SEE ALSO

Top

POE::Component::IRC

POE::Component::IRC::Plugin

POE-Component-IRC documentation Contained in the POE-Component-IRC distribution. 
package POE::Component::IRC::Plugin::ISupport;
BEGIN {
  $POE::Component::IRC::Plugin::ISupport::AUTHORITY = 'cpan:HINRIK';
}
BEGIN {
  $POE::Component::IRC::Plugin::ISupport::VERSION = '6.68';
}

use strict;
use warnings FATAL => 'all';
use POE::Component::IRC::Plugin qw(:ALL);

sub new {
    return bless { }, shift;
}

sub PCI_register {
    my ($self, $irc) = splice @_, 0, 2;

    $irc->plugin_register( $self => SERVER => qw(all) );
    $self->{irc} = $irc;
    $self->{parser} = {
        CASEMAPPING => sub {
            my ($support, $key, $val) = @_;
            $support->{$key} = $val;
        },
        CHANLIMIT => sub {
            my ($support, $key, $val) = @_;
            while ($val =~ /([^:]+):(\d+),?/g) {
                my ($k, $v) = ($1, $2);
                @{ $support->{$key} }{ split(//, $k) } = ($v) x length $k;
            }
        },
        CHANMODES => sub {
            my ($support, $key, $val) = @_;
            $support->{$key} = [ split(/,/, $val) ];
        },
        CHANTYPES => sub {
            my ($support, $key, $val) = @_;
            $support->{$key} = [ split(//, $val) ];
        },
        ELIST => sub {
            my ($support, $key, $val) = @_;
            $support->{$key} = [ split(//, $val) ];
        },
        IDCHAN => sub {
            my ($support, $key, $val) = @_;
            while ($val =~ /([^:]+):(\d+),?/g) {
                my ($k, $v) = ($1, $2);
                @{ $support->{$key} }{ split(//, $k) } = ($v) x length $k;
            }
        },
        MAXLIST => sub {
            my ($support, $key, $val) = @_;
            while ($val =~ /([^:]+):(\d+),?/g) {
                my ($k, $v) = ($1, $2);
                @{ $support->{$key} }{ split(//, $k) } = ($v) x length $k;
            }
        },
        PREFIX => sub {
            my ($support, $key, $val) = @_;
            if (my ($k, $v) = $val =~ /\(([^)]+)\)(.*)/ ) {
                @{ $support->{$key} }{ split(//, $k) } = split(//, $v);
            }
        },
        STATUSMSG => sub {
            my ($support, $key, $val) = @_;
            $support->{$key} = [ split(//, $val) ];
        },
        TARGMAX => sub {
            my ($support, $key, $val) = @_;
            while ($val =~ /([^:]+):(\d*),?/g) {
                my ($k, $v) = ($1, $2);
                $support->{$key}->{$k} = $v;
            }
        },
        EXCEPTS => sub {
            my ($support, $flag) = @_;
            $support->{$flag} = 'e';
        },
        INVEX => sub {
            my ($support, $flag) = @_;
            $support->{$flag} = 'I';
        },
    };

    return 1;
}

sub PCI_unregister {
    my ($self, $irc) = splice @_, 0, 2;
    delete $self->{irc};
    return 1;
}

sub S_connected {
    my ($self, $irc) = splice @_, 0, 2;

    $self->{server}   = { };
    $self->{got_005}  = 0;
    $self->{done_005} = 0;
    return PCI_EAT_NONE;
}

sub S_005 {
    my ($self, $irc, @args) = @_;
    my @vals = @{ ${ $args[2] } };
    pop @vals;
    my $support = $self->{server};

    for my $val (@vals) {
        if ($val =~ /=/) {
            my $key;
            ($key, $val) = split(/=/, $val, 2);
            if (defined $self->{parser}->{$key}) {
                $self->{parser}->{$key}->($support, $key, $val);
            }
            else {
                # AWAYLEN CHANNELLEN CHIDLEN CHARSET EXCEPTS INVEX KICKLEN
                # MAXBANS MAXCHANNELS MAXTARGETS MODES NETWORK NICKLEN STD
                # TOPICLEN WATCH
                $support->{$key} = $val;
            }
        }
        else {
            if (defined $self->{parser}->{$val}) {
                $self->{parser}->{$val}->($support, $val);
            }
            else {
                # ACCEPT CALLERID CAPAB CNOTICE CPRIVMSG FNC KNOCK MAXNICKLEN
                # NOQUIT PENALTY RFC2812 SAFELIST USERIP VCHANS WALLCHOPS
                # WALLVOICES WHOX
                $support->{$val} = 'on';
            }
        }
    }

    $self->{got_005}++;
    return PCI_EAT_NONE;
}

sub _default {
    my ($self, $irc, $event) = @_;

    return PCI_EAT_NONE if $self->{done_005};
    return PCI_EAT_NONE if !$self->{got_005};

    if ($event =~ /^S_(\d+)/ and $1 > 5) {
        $self->{done_005} = 1;
        $irc->send_event_now(irc_isupport => $self);
    }

    return PCI_EAT_NONE;
}

sub isupport {
    my $self = shift;
    my $value = uc ( $_[0] ) || return;

    return $self->{server}->{$value} if defined $self->{server}->{$value};
    return;
}

sub isupport_dump_keys {
    my $self = shift;

    if ( keys %{ $self->{server} } > 0 ) {
        return keys %{ $self->{server} };
    }
    return;
}

1;