File Coverage

blib/lib/Net/IRC2/Connection.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

#
# Copyright 2005, Karl Y. Pradene  All rights reserved.
#
#

package Net::IRC2::Connection   ;

use strict;      use warnings   ;
use Exporter                    ;
use IO::Socket::INET ()         ;
use Net::IRC2::Parser           ;

our @ISA       = qw( Exporter ) ;
our @EXPORT_OK = qw( new      ) ;
our @Export    = qw( new      ) ;

use vars qw( $VERSION $DEBUG )  ;
$VERSION    =                    '0.23' ;
$DEBUG      =                         0 ;


sub new {
    my $class = shift                                                          ;
    my $self = bless { @_ }                                                    ;

    $self->split_uri if exists $self->{'uri'}                                  ;
    my $sock = $self->socket( IO::Socket::INET->new( PeerAddr => $self->server ,
						     PeerPort => $self->port   ,
						     Proto    => 'tcp'         )
			    ) or ( warn "Can't bind : $@\n" and return undef ) ;
    $sock->send( 'PASS ' . $self->pass . "\n"                    .
                 'NICK ' . $self->nick . "\n"                    .
                 'USER ' . $self->user . ' foo.bar.quux '        .
		 $self->server . ' :' . $self->realname . "\n" ) ;
    $self->parser( new Net::IRC2::Parser )                       ;
    return $self                                                 }

sub start {
    my $self = shift           ;
    1 while $self->do_one_loop }

sub do_one_loop {
    my $self = shift;
    my ( $sock, $parser ) = ( $self->socket, $self->parser );
    my $line = <$sock>;
    my $event = $parser->message( $line ) or warn "\nParse error\n$line|\n" and return 1 ;
    $self->pong( $event->trailing ) if $event->command eq 'PING'                    ;
    $event->polish_up;
    $event->{'_parent'} = $self                                                     ;
    $self->chans( scalar $event->trailing ) if $event->command eq 'JOIN'            ;
    if (      defined $self->{ 'callback' }{ $event->command } ) {
	           &{ $self->{ 'callback' }{ $event->command } } ( $self, $event )  ;
    } elsif ( defined $self->{ 'callback' }{   'WaterGate'   } ) {
	           &{ $self->{ 'callback' }{   'WaterGate'   } } ( $self, $event )  }
    no strict 'refs'                                                                ;
    &{'cb'.$event->command}($self, $event) if defined &{'cb'.$event->command}       ;
    return $event                                                                   }

sub split_uri {
    # http://www.w3.org/Addressing/draft-mirashi-url-irc-01.txt
    # http://www.mozilla.org/projects/rt-messaging/chatzilla/irc-urls.html
    # irc:[[(/[][]|)]]
    # http://www.gbiv.com/protocols/uri/rfc/rfc3986.html
    # irc://nick!user@server:port/
    my $self = shift                                                             ;
    if ( exists $self->{'uri'} ) {
	$self->{'uri'} =~ m|^irc://(.+?)!(.+?)@(.+?):(\d+)/|                     ;
	$self->nick($1); $self->user($2); $self->server($3); $self->port($4)     }
                                                                                 }
sub sl        {
    shift->socket->send(    "@_\n" )                                             }


 ##############
# Commands IRC #
 ##############

{   my ( $code, $name ) = q{ sub { shift->sl( 'COMMAND' . " @_" ) } } ;
    no strict 'refs'                                                ;
    foreach $name qw( mode privmsg notice part whois join pong ) {
	$_ = $code ; s/COMMAND/$name/ ; *{$name} = eval      } }

############
# Accessor #
############
sub nick     { return   $_[0]->{  'nick'  } = $_[1] || $_[0]->{  'nick'  }
	                                            || $ENV{'USER'}        || 'nonick'         }
sub pass     { return   $_[0]->{'password'} = $_[1] || $_[0]->{'password'} || '2 young 2 die'  }
sub port     { return   $_[0]->{  'port'  } = $_[1] || $_[0]->{  'port'  } || 6667             }
sub user     { return   $_[0]->{  'user'  } = $_[1] || $_[0]->{  'user'  } || 'void'           }
sub realname { return   $_[0]->{'realname'} = $_[1] || $_[0]->{'realname'} || 'use Net::IRC2'  }
sub server   { return   $_[0]->{ 'server' } = $_[1] || $_[0]->{ 'server' } || 'localhost'      }
sub socket   { return   $_[0]->{ 'socket' } = $_[1] || $_[0]->{ 'socket' }                     }
sub parser   { return   $_[0]->{ 'parser' } = $_[1] || $_[0]->{ 'parser' }                     }
sub grammar  { return   $_[0]->{'grammar' } = $_[1] || $_[0]->{'grammar' }                     }
sub callback { return   $_[0]->{'callback'} = $_[1]   if ref $_[1] eq 'CODE'                   ;
               return &{$_[0]->{'callback'}}( $_[1] ) if ref $_[1] eq 'Net::IRC2::Events'      }

sub parent   { return   $_[0]->{'_parent' }                                                    }
sub chans    { return push ( @{shift->{'chans'}}, shift )                                      }

sub last_sl  { return   $_[0]->{'last_sl' } = $_[1] || $_[0]->{'last_sl' }                     }

sub add_default_handler { $_[0]->add_handler( [ 'WaterGate' ], $_[1] ) }

sub add_handler {
    my ( $self, $commands, $callback ) = @_                        ;
    $commands = [ $commands ] unless ref $commands eq 'ARRAY'      ;
    ( map { $self->{'callback'}{$_} = $callback } @$commands )     }

*add_global_handler = \&Net::IRC2::add_handler;

# sub dispatch { }

1;


__END__