File Coverage

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

Criterion	Covered	Total	%
statement	51	139	36.6
branch	1	16	6.2
condition			n/a
subroutine	14	26	53.8
pod	3	8	37.5
total	69	189	36.5

package POE::Component::IRC::Plugin::Blowfish;

use strict;
use warnings;
use POE;
use POE::Component::IRC::Plugin qw( :ALL );
use Crypt::Blowfish_PP;
use Carp qw/croak/;
use vars qw($VERSION);

$VERSION = '0.01';

use constant B64 =>
  './0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';

use constant states => qw/set_blowfish_key del_blowfish_key/;

sub new {
    my $package = shift;
    croak "Plugin requires an even number of parameters" if @_ % 2;

    my $self = { targets => {@_} };
    bless $self, $package;

    foreach my $chan ( keys %{ $self->{targets} } ) {
        $self->_set_key( $chan, $self->{targets}->{$chan} );
    }

    return $self;
}

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

    $irc->plugin_register( $self, 'SERVER', qw(public 001) );
    $irc->plugin_register( $self, 'USER',   qw(privmsg) );

    $self->{session_id} =
      POE::Session->create( object_states =>
          [ $self => [ qw/_shutdown _start/, map { "_$_" } states ], ], )->ID;

    $poe_kernel->state( $_ => $self ) for states;

    return 1;
}

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

    $poe_kernel->state($_) for states;
    $poe_kernel->call( $self->{session_id} => '_shutdown' );
    return 1;
}

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

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

sub set_blowfish_key {
    my ( $kernel, $self, $sender ) = @_[ KERNEL, OBJECT, SENDER ];
    $kernel->post( $self->{session_id}, '_set_blowfish_key', $sender,
        @_[ ARG0 .. $#_ ] );
}

sub del_blowfish_key {
    my ( $kernel, $self, $sender ) = @_[ KERNEL, OBJECT, SENDER ];
    $kernel->post( $self->{session_id}, '_del_blowfish_key', $sender,
        @_[ ARG0 .. $#_ ] );
}

sub _set_blowfish_key {
    my ( $kernel, $self, $sender, $chan, $key ) =
      @_[ KERNEL, OBJECT, ARG0 .. ARG2 ];
    my $old_key;
    $old_key = $self->{targets}->{$chan}->[1]
      if defined $self->{targets}->{$chan};
    $self->_set_key( $chan, $key );
}

sub _del_blowfish_key {
    my ( $kernel, $self, $sender, $chan ) = @_[ KERNEL, OBJECT, ARG0, ARG1 ];
        delete $self->{targets}->{$chan} if defined $self->{targets}->{$chan};
}

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

    # get this plugin to the pole position
    $irc->pipeline->bump_up($self) while $irc->pipeline->get_index($self) > 0;

    return PCI_EAT_NONE;
}

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

    my $line = ${ $_[0] };
    my ( $target, $msg ) = $line =~ /PRIVMSG (.*?) :(.*?)$/;

    return PCI_EAT_NONE unless defined $self->{targets}->{$target};

    $msg = sprintf '+OK %s',
      $self->_encrypt( $msg, $self->{targets}->{$target}->[0] );

    ${ $_[0] } = sprintf 'PRIVMSG %s :%s', $target, $msg;

    return PCI_EAT_NONE;
}

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

    my ($nick)   = ( split /!/, ${ $_[0] } )[0];
    my ($target) = ${ $_[1] }->[0];
    my ($msg)    = ${ $_[2] };

    if ( defined $self->{targets}->{$target} ) {
        if ($msg =~ s/^\+OK //) {
            $msg = $self->_decrypt( $msg, $self->{targets}->{$target}->[0] );
            $msg =~ s/\0//g;
            ${ $_[2] } = $msg;
        }
    }

    return PCI_EAT_NONE;
}

sub _encrypt {
    my ( $self, $text, $key ) = @_;

    $text =~ s/(.{8})/$1\n/g;
    my $result = '';
    my $cipher = new Crypt::Blowfish_PP $key;
    foreach ( split /\n/, $text ) {
        $result .= $self->_inflate( $cipher->encrypt($_) );
    }

    return $result;
}

sub _decrypt {
    my ( $self, $text, $key ) = @_;

    $text =~ s/(.{12})/$1\n/g;
    my $result = '';
    my $cipher = new Crypt::Blowfish_PP $key;
    foreach ( split /\n/, $text ) {
        $result .= $cipher->decrypt( $self->_deflate($_) );
    }

    return $result;
}

sub _set_key {
    my ( $self, $chan, $key ) = @_;

    $self->{targets}->{$chan} = [ $key, $key ];

    my $l = length($key);

    if ( $l < 8 ) {
        my $longkey = '';
        my $i       = 8 / $l;
        $i = $1 + 1 if $i =~ /(\d+)\.\d+/;
        while ( $i > 0 ) {
            $longkey .= $key;
            $i--;
        }
        $self->{targets}->{$chan} = [ $longkey, $key ];
    }
}

sub _inflate {
    my ( $self, $text ) = @_;
    my $result = '';
    my $k      = -1;

    while ( $k < ( length($text) - 1 ) ) {
        my ( $l, $r ) = ( 0, 0 );
        for ( $l, $r ) {
            foreach my $i ( 24, 16, 8 ) {
                $_ += ord( substr( $text, ++$k, 1 ) ) << $i;
            }
            $_ += ord( substr( $text, ++$k, 1 ) );
        }
        for ( $r, $l ) {
            foreach my $i ( 0 .. 5 ) {
                $result .= substr( B64, $_ & 0x3F, 1 );
                $_ = $_ >> 6;
            }
        }
    }
    return $result;
}

sub _deflate {
    my ( $self, $text ) = @_;
    my $result = '';
    my $k      = -1;

    while ( $k < ( length($text) - 1 ) ) {
        my ( $l, $r ) = ( 0, 0 );
        for ( $r, $l ) {
            foreach my $i ( 0 .. 5 ) {
                $_ |= index( B64, substr( $text, ++$k, 1 ) ) << ( $i * 6 );
            }
        }
        for ( $l, $r ) {
            foreach my $i ( 0 .. 3 ) {
                $result .=
                  chr( ( $_ & ( 0xFF << ( ( 3 - $i ) * 8 ) ) )
                    >> ( ( 3 - $i ) * 8 ) );
            }
        }
    }

    return $result;
}

1;
__END__