File Coverage

blib/lib/POE/Component/IRC/Plugin/CoreList.pm

Criterion	Covered	Total	%
statement	23	68	33.8
branch	0	24	0.0
condition	0	14	0.0
subroutine	8	11	72.7
pod	1	5	20.0
total	32	122	26.2

package POE::Component::IRC::Plugin::CoreList;

use strict;
use warnings;
use Module::CoreList;
use POE::Component::IRC::Plugin qw(:ALL);
use vars qw($VERSION);

$VERSION = '1.02';

my $cmds  = qr/find|search|release|date/;

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

sub PCI_register {
  my ($self,$irc) = @_;
  $irc->plugin_register( $self, 'SERVER', qw(public msg) );
  return 1;
}

sub PCI_unregister {
  return 1;
}

sub S_public {
  my ($self,$irc) = splice @_, 0 , 2;
  my ($nick,$userhost) = ( split /!/, ${ $_[0] } )[0..1];
  my $channel = ${ $_[1] }->[0];
  my $what = ${ $_[2] };
  my $mynick = $irc->nick_name();
  my $cmdstr = $self->{command} || '';
  my ($string) = $what =~ m/^\s*\Q$mynick\E[\:\,\;\.]?\s*(.*)$/i;
  return PCI_EAT_NONE unless ( $string and $string =~ /^\Q$cmdstr\E\s*(?:($cmds))?\s*(.*)/io );
  my ( $command, $module, @args ) = ( $1 || 'release', split /\s+/, $2 );
  my $reply = _corelist( $command, $module, @args );
  $irc->yield( 'privmsg', $channel, $reply );
  return PCI_EAT_NONE;
}

sub S_msg {
  my ($self,$irc) = splice @_, 0 , 2;
  my ($nick,$userhost) = ( split /!/, ${ $_[0] } )[0..1];
  my $string = ${ $_[2] };
  my $cmdstr = $self->{command} || '';
  return PCI_EAT_NONE unless ( $string and $string =~ /^\Q$cmdstr\E\s*(?:($cmds))?\s*(.*)/io );
  my ( $command, $module, @args ) = ( $1 || 'release', split /\s+/, $2 );
  my $reply = _corelist( $command, $module, @args );
  $irc->yield( ( $self->{privmsg} ? 'privmsg' : 'notice' ), $nick, $reply );
  return PCI_EAT_NONE;
}

sub _corelist {
  my ($command,$module,@args) = @_;
  # compute the reply
  my $reply;
  if ( $command =~ /^(?:find|search)$/i ) {
        my @modules = Module::CoreList->find_modules( qr/$module/, @args );

        # shorten large response lists
        @modules = (@modules[0..8], '...') if @modules > 9;

        local $" = ', ';
        my $where = ( @args ? " in perl @args" : '' );
        $reply = ( @modules
            ? "Found @modules"
            : "Found no module matching /$module/" )
            . $where;
  }
  else {
        my ( $release, $patchlevel, $date )
            = ( Module::CoreList->first_release($module), '', '' );
        if ($release) {
            $date  = $Module::CoreList::released{$release};
        }
        my $rem;
        if ( Module::CoreList->can('removed_from') ) {
          my $removed = Module::CoreList->removed_from($module);
          if ( $removed ) {
            my $remdate = $Module::CoreList::released{$removed};
            $rem = " and removed from $removed (released on $remdate)";
          }
        }
        $reply = $release
            ? "$module was first released with perl $release ("
            . "released on $date)"
            . ( $rem ? $rem : '' )
            : "$module is not in the core";
  }
  return $reply;
}

1;
__END__