File Coverage

blib/lib/POE/Component/IRC/Plugin/CPAN/Info.pm

Criterion	Covered	Total	%
statement	18	244	7.3
branch	0	140	0.0
condition	0	15	0.0
subroutine	6	26	23.0
pod	0	6	0.0
total	24	431	5.5

package POE::Component::IRC::Plugin::CPAN::Info;

use warnings;
use strict;

our $VERSION = '1.001002'; # VERSION

use Carp;
use POE;
use POE::Component::IRC::Plugin (qw( :ALL ));
use POE::Component::CPAN::SQLite::Info;

sub new {
    my $package = shift;
    my %args = @_;
    $args{ lc $_ } = delete $args{ $_ } for keys %args;

    # load defaults and override with user args if any
    %args = (
        mirror              => 'http://cpan.perl.org/',
        path                => 'cpan_sqlite_info',
        debug               => 0,
        freshen_interval    => 43200,
        got_info_event      => 'cpaninfo_got_info',
        no_result_event     => 'cpaninfo_no_result',
        response_event      => 'cpaninfo_response',
        respond_no_result   => 1,
        send_events         => 1,
        show_help           => 1,
        eat                 => 0,
        listen_for_help     => [ qw(public notice privmsg) ],
        listen_for_input    => [ qw(public notice privmsg) ],
        no_result_responses => [ 'No clue', 'No idea' ],
        max_modules_limit   => 5,
        max_modules_length  => 300,
        max_output_length   => 600,
        max_output_length_pub => 400,
        output_line_length  => 300,
        banned              => [],
        %args,
    );

    for my $listen_type (qw( listen_for_help  listen_for_input )) {
        $args{ $listen_type } = {
            map { lc $_ => 1 }
                @{ $args{ $listen_type } }
        };
    }

    unless ( exists $args{ua_args}{timeout} ) {
        $args{ua_args}{timeout}  = 30;
    }

    if ( exists $args{channels} and ref $args{channels} ne 'ARRAY' ) {
        carp "Argument `channels` must contain an arrayref..";
        return;
    }

    # assign default triggers to anything not specified by user.
    my $default_triggers_ref = _make_default_triggers();
    if ( exists $args{triggers} ) {

        foreach my $trigger_category (qw( mod dist auth )) {
            my $cat_triggers = $default_triggers_ref->{ $trigger_category};

            $args{triggers}{ $trigger_category } = {
                %$cat_triggers,
                %{ $args{triggers}{ $trigger_category } || {} },
            };

            my $cat_trigger = "${trigger_category}_cat";
            unless ( exists $args{triggers}{ $cat_trigger } ) {
                $args{trigger}{ $cat_trigger }
                    = $default_triggers_ref->{ $cat_trigger};
            }
        }
    }
    else {
        $args{triggers} = $default_triggers_ref;
    }

    # assign default help triggers for anything not specified by user
    my $default_help_ref     = _make_default_help_triggers();
    if ( exists $args{help} ) {
        foreach my $category (qw(mod dist auth)) {
            my $cat_help = $default_help_ref->{ $category };

            $args{help}{ $category } = {
                %$cat_help,
                %{ $args{help}{ $category } || {} },
            };

            my $cat_trigger = "${category}_cat";
            unless ( exists $args{help}{ $cat_trigger } ) {
                $args{help}{ $cat_trigger }
                    = $default_help_ref->{help}{ $cat_trigger };
            }
        }
    }
    else {
        $args{help} = $default_help_ref;
    }

    unless ( exists $args{help}{help_re} ) {
        $args{help}{help_re} = $default_help_ref->{help_re};
    }

    return bless \%args, $package;
}

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

    $self->{irc} = $irc;

    $irc->plugin_register( $self, 'SERVER', qw(notice public msg) );

    $self->{_session_id} = POE::Session->create(
        object_states => [
            $self => [
                qw(
                    _start
                    _shutdown
                    _fetched
                    _freshen
                    _got_info
                )
            ]
        ],
    )->ID;


    return 1;
}

sub _start {
    my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];
    $self->{_session_id} = $_[SESSION]->ID();
    $kernel->refcount_increment( $self->{_session_id}, __PACKAGE__ );

    $self->{poco} = POE::Component::CPAN::SQLite::Info->spawn(
        map { $_, $self->{$_} }
            qw(mirror debug path)
    );

    warn "Sending `freshen` request to PoCo::CPAN::SQLite::Info"
        if $self->{debug};

    $self->{poco}->freshen( {
            event  => '_fetched',
            ua_args => $self->{ua_args},
        }
    );
    $self->{_freshen_alarm} = $kernel->delay(
        '_freshen' => $self->{freshen_interval}
    );
    undef;
}

sub _shutdown {
    my ($kernel, $self) = @_[ KERNEL, OBJECT ];
    $self->{poco}->shutdown;
    $kernel->alarm_remove_all();
    $kernel->refcount_decrement( $self->{_session_id}, __PACKAGE__ );
    undef;
}

sub PCI_unregister {
    my $self = shift;

    # Plugin is dying make sure our POE session does as well.
    $poe_kernel->call( $self->{_session_id} => '_shutdown' );

    delete $self->{irc};

    return 1;
}


sub _freshen {
    my ( $kernel, $self ) = @_[ KERNEL, OBJECT ];

    $self->{poco}->freshen( {
                event  => '_fetched',
                ua_args => $self->{ua_args},
            }
    );

    $self->{_freshen_alarm} = $kernel->delay(
        '_freshen' => $self->{freshen_delay}
    );
}

sub _fetched {
    my ( $kernel, $self, $input ) = @_[ KERNEL, OBJECT, ARG0 ];

    if ( $input->{freshen_error} ) {
        if ( $self->{debug} ) {
            if ( $input->{freshen_error} eq 'fetch' ) {
                warn "Could not fetch file(s)\n";
                foreach my $file ( keys %{ $input->{freshen_errors} } ) {
                    print "\t$file  => $input->{freshen_errors}{ $file }\n";
                }
            }
            else {
                warn "Failed to create storage dir:"
                     . " $input->{freshen_error}\n";
            }
        }
        $self->{_freshen_alarm} = $kernel->delay(
            '_freshen' => $self->{freshen_interval} < 30
                        ?  $self->{freshen_interval} : 30,
        );
    }
    else {
        warn "`freshen` success sending `fetch_info` request"
            if $self->{debug};

        $self->{poco}->fetch_info( { event   => '_got_info' } );
    }
}

sub _got_info {
    my ( $self, $input ) = @_[ OBJECT, ARG0 ];

    warn "_got_info success"
        if $self->{debug};

    delete $input->{path};

    $self->{_data} = $input;

    $self->{irc}->send_event( $self->{got_info_event} => time() )
        if $self->{send_events};
}

sub S_public {
    my ( $self, $irc ) = splice @_, 0, 2;
    my $who     = ${ $_[0] };
    my $channel = ${ $_[1] }->[0];
    my $message = ${ $_[2] };
    return $self->_parse_input( $irc, $who, $channel, $message, 'public' );
}

sub S_notice {
    my ( $self, $irc ) = splice @_, 0, 2;
    my $who     = ${ $_[0] };
    my $channel = ${ $_[1] }->[0];
    my $message = ${ $_[2] };
    return $self->_parse_input( $irc, $who, $channel, $message, 'notice' );
}

sub S_msg {
    my ( $self, $irc ) = splice @_, 0, 2;
    my $who     = ${ $_[0] };
    my $channel = ${ $_[1] }->[0];
    my $message = ${ $_[2] };
    return $self->_parse_input( $irc, $who, $channel, $message, 'privmsg' );
}

sub _parse_input {
    my ( $self, $irc, $who, $channel, $message, $type ) = @_;

    return PCI_EAT_NONE
        if !exists $self->{listen_for_input}{ $type }
            and !$self->{send_events};

    foreach my $ban_re ( @{ $self->{banned} || [] } ) {
        return PCI_EAT_NONE
            if $who =~ /$ban_re/;
    }

    my $my_nick = $irc->nick_name();
    my $what;
    if ( $type eq 'public' ) {
        ($what) = $message =~ m/^\s*\Q$my_nick\E[\:\,\;\.]?\s*(.*)$/i;
    }
    else {
        $what = $message;
    }

    return PCI_EAT_NONE
        unless defined $what;

    warn "Got PUBLIC input: [ who => $who, channel => $channel, "
            . "what => $what ]"
        if $self->{debug};

    my $response;

    eval { $response = $self->_parse_commands( $what ); };
    # if $@ => did not match trigger,
    # if undef $response => no data available for this request
    if ( $@ ) {
        $response = $self->_parse_help( $what )
            if $self->{help}
                and exists $self->{listen_for_help}{ $type };

        warn "_parse_command( $what ) did not match anything"
            if $self->{debug} and not defined $response;

        return PCI_EAT_NONE
            unless defined $response;
    }


    my ( $nick ) = split /!/, $who;
    unless ( defined $response ) {
        if ( $self->{respond_no_result} ) {
            my $responses_ref = $self->{no_result_responses};

            if ( $type eq 'public' ) {
                $poe_kernel->post( $irc => privmsg => $channel =>
                    "$nick, " . $responses_ref->[ rand @$responses_ref ]
                );
            }
            else {
                $poe_kernel->post( $irc => $type => $nick =>
                    $responses_ref->[ rand @$responses_ref ]
                );
            }
        }
        $self->{irc}->send_event(
            $self->{no_result_event} => {
                'time'  => time(),
                who     => $who,
                channel => $channel,
                what    => $message,
                type    => $type,
            }
        ) if $self->{send_events};

        return PCI_EAT_NONE;
    }

    warn "Got response `$response`"
        if $self->{debug};

    my $max_length = $type eq 'public'
                   ? $self->{max_output_length_pub}
                   : $self->{max_output_length    };

    if ( length $response > $max_length ) {
        $response = substr $response, 0, $max_length - 3;
        $response .= '...';
    }

    # break long output into several lines to prefed "Excess Flood" drops
    my @responses;
    while ( length $response > $self->{output_line_length} ) {
        push @responses, substr $response, 0, $self->{output_line_length};
        $response = substr $response, $self->{output_line_length};
    }
    push @responses, $response;

    if ( exists $self->{ listen_for_input }{ $type } ) {
        if ( $type eq 'public' ) {
            $poe_kernel->post( $irc => privmsg => $channel =>
                "$nick, $_"
            ) for @responses;
        }
        else {
            $poe_kernel->post( $irc => $type => $nick => $_ )
                for @responses;
        }
    }

    if ( $self->{send_events} ) {
        for ( @responses ) {
            $self->{irc}->send_event(
                $self->{response_event} => {
                    'time'   => time(),
                    who      => $who,
                    channel  => $channel,
                    what     => $message,
                    type     => $type,
                    response => $_
                }
            );
        }
    }

    return $self->{eat} ? PCI_EAT_ALL : PCI_EAT_NONE;
}

sub _parse_help {
    my ( $self, $what ) = @_;
    my $trigs = _make_default_help_triggers();

    return
        unless defined $what and $what =~ s/$trigs->{help_re}//;

    return $self->_make_help_list
        unless length $what;


    my $help_data_ref = _make_help_data();
    $what =~ s/^\s+|\s+$//g;
    $what = lc $what;
    if ( $what =~ s/^$trigs->{mod_cat}//i ) {
        return $help_data_ref->{mod}{ $what };
    }
    elsif ( $what =~ s/^$trigs->{auth_cat}//i ) {
        return $help_data_ref->{auth}{ $what };

    }
    elsif ( $what =~ s/^$trigs->{dist_cat}//i ) {
        return $help_data_ref->{dist}{ $what };
    }
    return;
}

sub _parse_commands {
    my ( $self, $what ) = @_;

    my $response;
    if ( $what =~ s/$self->{triggers}{mod_cat}// ) {
        my $triggers = $self->{triggers}{mod};

        if ( $what =~ s/$triggers->{distname}// ) {
            $response = $self->_make_info( mods => $what => 'dist_name' );
        }
        elsif ( $what =~ s/$triggers->{version}// ) {
            $response = $self->_make_info( mods => $what => 'mod_vers' );
        }
        elsif ( $what =~ s/$triggers->{desc}// ) {
            $response = $self->_make_info( mods => $what => 'mod_abs' );
        }
        elsif ( $what =~ s/$triggers->{chapter}// ) {
            $response = $self->_make_info( mods => $what => 'chapterid' );
        }
        elsif ( $what =~ s/$triggers->{dslip}// ) {
            $response = $self->_make_info( mods => $what => 'dslip' );
        }
        else {
            die;
        }
    }
    elsif ( $what =~ s/$self->{triggers}{auth_cat}// ) {
        my $triggers = $self->{triggers}{auth};

        if ( $what =~ s/$triggers->{email}// ) {
            $response = $self->_make_info(auths => uc $what => 'email' );
        }
        elsif ( $what =~ s/$triggers->{name}// ) {
            $response
                = $self->_make_info( auths => uc $what => 'fullname' );
        }
        else {
            die
        }
    }
    elsif ( $what =~ s/$self->{triggers}{dist_cat}// ) {
        my $triggers = $self->{triggers}{dist};
        if ( $what =~ s/$triggers->{version}// ) {
            $response = $self->_make_info( dists => $what => 'dist_vers');
        }
        elsif ( $what =~ s/$triggers->{file}// ) {
            $response = $self->_make_info( dists => $what => 'dist_file');
        }
        elsif ( $what =~ s/$triggers->{auth}// ) {
            $response = $self->_make_info( dists => $what => 'cpanid' );
        }
        elsif ( $what =~ s/$triggers->{desc}// ) {
            $response = $self->_make_info( dists => $what => 'dist_abs' );
        }
        elsif ( $what =~ s/$triggers->{mods}// ) {
            $response = $self->_make_info( dists => $what => 'modules' );
        }
        elsif ( $what =~ s/$triggers->{chapter}// ) {
            $response = $self->_make_info( dists => $what => 'chapterid' );
        }
        else {
            die;
        }
    }
    else {
        die;
    }
    return $response;
}

sub _make_help_list {
    my $self = shift;

    my $help_data_ref = _make_default_help_triggers();
    my @help_list;
    foreach my $category (qw( dist mod auth )) {
        my $cat_prefix = $help_data_ref->{ $category . '_cat' };
        push @help_list, join q|, |,
                        map { $cat_prefix . $_ }
                            sort keys %{ $help_data_ref->{ $category } };
    }
    return join q|, |, @help_list;
}

sub _make_info {
    my ( $self, $category, $item, $section ) = @_;
    return
        unless defined $section;

    $item =~ s/^\s+|\s+$//g;
    return
        unless length $item;

    unless ( exists $self->{_data}{ $category }{ $item } ) {
        warn "Did not find {_data}{ $category }{ $item }"
            if $self->{debug};

        return;
    }

    my $data = $self->{_data}{ $category }{ $item };


    if ( exists $data->{ $section } ) {
        if ( $category eq 'dists' ) {
            if ( $section eq 'modules' ) {
                return $self->_prepare_dist_modules( $data->{ $section } );
            }
            elsif ( $section eq 'chapterid' ) {
                return $self->_prepare_dist_chapterid($data->{ $section });
            }
        }
        return $data->{ $section };
    }
    else {
        return;
    }
}

sub _prepare_dist_modules {
    my ( $self, $modules_ref ) = @_;
    return
        unless ref $modules_ref eq 'HASH';

    my @modules = keys %$modules_ref;

    if ( @modules > $self->{max_modules_limit} ) {
        return "Uses " . @modules . " modules...";
    }
    else {
        my $mods = join ' | ', @modules;
        if ( length $mods > $self->{max_modules_length} ) {
            $mods = "(total: " . @modules . " ) $mods";
            $mods = substr $mods, 0, $self->{max_modules_length} - 3;
            $mods .= '...';
        }
        return $mods;
    }
}

sub _make_default_help_triggers {
    return {
        help_re => qr/^help\s*/i,
        mod_cat => 'mod_',
        mod     => {
            distname    => 'distname',
            version     => 'version',
            desc        => 'desc',
            chapter     => 'chapter',
            dslip       => 'dslip',
        },
        auth_cat  => 'auth_',
        auth     => {
            email       => 'email',
            name        => 'name',
        },

        dist_cat => 'dist_',
        dist     => {
            version     => 'version',
            file        => 'file',
            auth        => 'auth',
            desc        => 'desc',
            mods        => 'mods',
            chapter     => 'chapter',
        },
    };
}

sub _make_help_data {
    return {
        mod => {
            distname    => q|Which distribution the module is in|,
            version     => q|Module's version|,
            desc        => q|Module's description|,
            chapter     => q|Module's chapter|,
            dslip       => q|Module's DSLIP code|,
        },
        auth => {
            email       => q|Author's e-mail address|,
            name        => q|Author's full name|,
        },
        dist => {
            version     => q|Distribution's version|,
            file        => q|Distribution's CPAN filename|,
            auth        => q|Distribution's author|,
            desc        => q|Distribution's description|,
            mods        => q|List modules included in the distribution|,
            chapter     => q|Chapter and subchapter of the distribution|,
        },
    };
}

sub _make_default_triggers {
    return {
        mod_cat  => qr/ ^ mod_ /xi,
        mod      => {
            distname    => qr/ ^ distname \s+ /xi,
            version     => qr/ ^ version  \s+ /xi,
            desc        => qr/ ^ desc     \s+ /xi,
            chapter     => qr/ ^ chapter  \s+ /xi,
            dslip       => qr/ ^ dslip    \s+ /xi,
        },

        auth_cat  => qr/ ^auth_ /xi,
        auth     => {
            email       => qr/ ^ email    \s+ /xi,
            name        => qr/ ^ name     \s+ /xi,
        },

        dist_cat => qr/ ^ dist_ /xi,
        dist     => {
            version     => qr/ ^ version  \s+ /xi,
            file        => qr/ ^ file     \s+ /xi,
            auth        => qr/ ^ auth     \s+ /xi,
            desc        => qr/ ^ desc     \s+ /xi,
            mods        => qr/ ^ mods     \s+ /xi,
            chapter     => qr/ ^ chapter  \s+ /xi,
        },
    };
}

1;
__END__