File Coverage

blib/lib/POE/Component/IRC/Service/P10.pm

Criterion	Covered	Total	%
statement	242	983	24.6
branch	68	362	18.7
condition	36	256	14.0
subroutine	35	125	28.0
pod	34	87	39.0
total	415	1813	22.8

# Author: Chris "BinGOs" Williams
# Derived from code by Dennis Taylor
#
# This module may be used, modified, and distributed under the same
# terms as Perl itself. Please see the license that came with your Perl
# distribution for details.
#

package POE::Component::IRC::Service::P10;

use strict;
use POE qw( Wheel::SocketFactory Wheel::ReadWrite Driver::SysRW
            Filter::Line Filter::Stream );
use POE::Filter::IRC::P10;
use POE::Filter::CTCP::P10;
use Carp;
use Socket;
use Sys::Hostname;
use Time::HiRes qw (gettimeofday);
use vars qw($VERSION);

$VERSION = '0.998';

my %cmd2token = ('ACCOUNT' => 'AC', 'ADMIN' => 'AD', 'ASLL' => 'LL', 'AWAY' => 'A', 'BURST' => 'B', 'CLEARMODE' => 'CM', 'CLOSE' => 'CLOSE', 'CNOTICE' => 'CN', 'CONNECT' => 'CO', 'CPRIVMSG' => 'CP', 'CREATE' => 'C', 'DESTRUCT' => 'DE', 'DESYNCH' => 'DS', 'DIE' => 'DIE', 'DNS' => 'DNS', 'END_OF_BURST' => 'EB', 'EOB_ACK'  => 'EA', 'ERROR' => 'Y', 'GET' => 'GET', 'GLINE' => 'GL', 'HASH' => 'HASH', 'HELP' => 'HELP', 'INFO' => 'F', 'INVITE' => 'I', 'ISON' => 'ISON', 'JOIN' => 'J', 'JUPE' => 'JU', 'KICK' => 'K', 'KILL' => 'D', 'LINKS' => 'LI', 'LIST' => 'LIST', 'LUSERS' => 'LU', 'MAP' => 'MAP', 'MODE' => 'M', 'MOTD' => 'MO', 'NAMES' => 'E', 'NICK' => 'N', 'NOTICE' => 'O', 'OPER' => 'OPER', 'OPMODE' => 'OM', 'PART' => 'L', 'PASS' => 'PA', 'PING' => 'G', 'PONG' => 'Z', 'POST' => 'POST', 'PRIVMSG' => 'P', 'PRIVS' => 'PRIVS', 'PROTO' => 'PROTO', 'QUIT' => 'Q', 'REHASH' => 'REHASH', 'RESET' => 'RESET', 'RESTART' => 'RESTART', 'RPING' => 'RI', 'RPONG' => 'RO', 'SERVER' => 'S', 'SET' => 'SET', 'SETTIME' => 'SE', 'SILENCE' => 'U', 'SQUIT' => 'SQ', 'STATS' => 'R', 'TIME' => 'TI', 'TOPIC' => 'T', 'TRACE' => 'TR', 'UPING' => 'UP', 'USER' => 'USER', 'USERHOST' => 'USERHOST', 'USERIP' => 'USERIP', 'VERSION' => 'V', 'WALLCHOPS' => 'WC', 'WALLOPS' => 'WA', 'WALLUSERS' => 'WU', 'WALLVOICES' => 'WV', 'WHO' => 'H', 'WHOIS' => 'W', 'WHOWAS' => 'X');

use constant PCI_REFCOUNT_TAG => "P::C::I registered";

use constant CMD_PRI => 0;
use constant CMD_SUB => 1;

my %irc_commands =
   ('quit'      => \&oneoptarg_client,
    'nick'      => \&onlyonearg_client,
    'invite'    => \&onlytwoargs_client,
    'kill'      => \&onlytwoargs,
    'account'   => \&onlytwoargs,
    'clearmode' => \&onlytwoargs,
    'opmode'    => \&spacesep,
    'gline'     => \&spacesep,
    'jupe'      => \&spacesep,
    'privmsg'   => \&privandnotice,
    'notice'    => \&privandnotice,
    'stats'     => \&spacesep_client,
    'links'     => \&spacesep_client,
    'mode'      => \&spacesep_client,
    'part'      => \&commasep_client,
    'ctcp'      => \&ctcp,
    'ctcpreply' => \&ctcp,
  );

# Create a new IRC Service

sub new {
  my ($package,$alias,$hash) = splice @_, 0, 3;
  my ($package_events);

  unless ($alias and $hash) {
        croak "Not enough parameters to POE::Component::IRC::Service::P10::new()";
  }

  unless (ref $hash eq 'HASH') {
        croak "Second argument to POE::Component::IRC::Service::P10::new() must be a hash reference";
  }

  $hash->{EventMode} = 1 unless ( defined ( $hash->{EventMode} ) and $hash->{EventMode} == 0 );

  $hash->{Reconnect} = 0 unless ( defined ( $hash->{Reconnect} ) and $hash->{Reconnect} == 1 );

  $hash->{Debug} = 0 unless ( defined ( $hash->{Debug} ) and $hash->{Debug} == 1 );

  if ( $hash->{EventMode} == 1 ) {
    $package_events = [qw( _start
                           _stop
                           _parseline
		           _sock_up
		           _sock_down
		           _sock_failed
			   autoping
                           addnick
                           connect
                           topic
			   irc_p10_disconnected
			   irc_p10_socketerr
		           irc_p10_stats
			   irc_p10_version
		           irc_p10_server_link
			   irc_p10_server
			   irc_p10_squit
			   irc_p10_burst
		           irc_p10_end_of_burst
			   irc_p10_eob_ack
                           irc_p10_ping
		           irc_p10_quit
		           irc_p10_kill
			   irc_p10_nick
			   irc_p10_whois
			   irc_p10_account
			   irc_p10_create
			   irc_p10_join
			   irc_p10_part
			   irc_p10_kick
			   irc_p10_mode
			   irc_p10_opmode
			   irc_p10_clearmode
                           kick
			   join
		           register
		           sl_server
		           sl_client
                           shutdown
		           squit
		           unregister)];
  } else {
    $package_events = [qw( _start
                           _stop
                           _parseline
		           _sock_up
		           _sock_down
		           _sock_failed
			   autoping
                           addnick
                           connect
                           topic
			   irc_p10_disconnected
			   irc_p10_socketerr
		           irc_p10_stats
			   irc_p10_version
		           irc_p10_server_link
			   irc_p10_server
			   irc_p10_squit
		           irc_p10_end_of_burst
			   irc_p10_eob_ack
                           irc_p10_ping
		           irc_p10_quit
		           irc_p10_kill
			   irc_p10_nick
			   irc_p10_whois
			   irc_p10_account
			   irc_p10_mode
                           kick
			   join
		           register
		           sl_server
		           sl_client
                           shutdown
		           squit
		           unregister)];
  }

  # Create our object
  my ($self) = { };
  bless ($self);

  # Parse the passed hash reference
  unless ($hash->{'ServerNumeric'} and $hash->{'ServerName'} and $hash->{'RemoteServer'} and $hash->{'Password'} and $hash->{'ServerPort'}) {
	croak "You must specify ServerNumeric, ServerName, RemoteServer, Password and ServerPort in your hash reference.";
  }

  # Is numeric in proper format ie. P10 Base64 if not convert it
  if ($hash->{'ServerNumeric'} =~ /^[0-9]+?$/) {
      if ($hash->{'ServerNumeric'} < 0 or $hash->{'ServerNumeric'} > 4095) {
        die "ServerNumeric must be either 0-4095 or a valid P10 Base64 numeric\n";
      } else {
        $hash->{'ServerNumeric'} = dectobase64($hash->{'ServerNumeric'});
      }
  }

  if ($hash->{'ServerNumeric'} !~ /^[ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789\[\]]{2}$/) {
        die "ServerNumeric must be either 0-4095 or a valid P10 Base64 numeric\n";
  }

  $hash->{ServerDesc} = "*** POE::Component::IRC::Service ***" unless defined ($hash->{ServerDesc});
  $hash->{Version} = "POE-Component-IRC-Service-P10-$VERSION" unless defined ($hash->{Version});

  my @event_map = map {($_, $irc_commands{$_})} keys %irc_commands;

  $hash->{'PingFreq'} = 90 unless ( defined ( $hash->{'PingFreq'} ) );

  POE::Session->create( inline_states => { @event_map },
			package_states => [
                        $package => $package_events, ],
                     	args => [ $alias, @_ ],
			heap => { State => $self,
				  servernum => $hash->{'ServerNumeric'},
				  servername => $hash->{'ServerName'},
				  serverdesc => $hash->{'ServerDesc'},
				  remoteserver => $hash->{'RemoteServer'},
				  serverport => $hash->{'ServerPort'},
				  password => $hash->{'Password'},
				  localaddr => $hash->{'LocalAddr'},
				  pingfreq => $hash->{'PingFreq'},
				  eventmode => $hash->{'EventMode'},
				  reconnect => $hash->{'Reconnect'},
				  debug => $hash->{'Debug'},
				  his_servername => $hash->{'HIS_SERVERNAME'},
				  his_serverinfo => $hash->{'HIS_SERVERINFO'},
				  version => $hash->{'Version'}, },
		      );
   return $self;
}

# Register and unregister to receive events

sub register {
  my ($kernel, $heap, $session, $sender, @events) =
    @_[KERNEL, HEAP, SESSION, SENDER, ARG0 .. $#_];

  die "Not enough arguments" unless @events;

  # FIXME: What "special" event names go here? (ie, "errors")
  # basic, dcc (implies ctcp), ctcp, oper ...what other categories?
  foreach (@events) {
    $_ = "irc_p10_" . $_ unless /^_/;
    $heap->{events}->{$_}->{$sender} = $sender;
    $heap->{sessions}->{$sender}->{'ref'} = $sender;
    unless ($heap->{sessions}->{$sender}->{refcnt}++ or $session == $sender) {
      $kernel->refcount_increment($sender->ID(), PCI_REFCOUNT_TAG);
    }
  }
}

sub unregister {
  my ($kernel, $heap, $session, $sender, @events) =
    @_[KERNEL,  HEAP, SESSION,  SENDER,  ARG0 .. $#_];

  die "Not enough arguments" unless @events;

  foreach (@events) {
    delete $heap->{events}->{$_}->{$sender};
    if (--$heap->{sessions}->{$sender}->{refcnt} <= 0) {
      delete $heap->{sessions}->{$sender};
      unless ($session == $sender) {
        $kernel->refcount_decrement($sender->ID(), PCI_REFCOUNT_TAG);
      }
    }
  }
}

# Session starts or stops

sub _start {
  my ($kernel, $session, $heap, $alias) = @_[KERNEL, SESSION, HEAP, ARG0];
  my @options = @_[ARG1 .. $#_];

  $session->option( @options ) if @options;
  $kernel->alias_set($alias);
  $kernel->yield( 'register', qw(stats server_link server squit burst end_of_burst eob_ack ping quit kill nick whois account create join part kick mode opmode clearmode version disconnected socketerr) );
  $heap->{irc_filter} = POE::Filter::IRC::P10->new();
  $heap->{ctcp_filter} = POE::Filter::CTCP::P10->new();
  $heap->{irc_filter}->debug(1) if ( $heap->{debug} );
  $heap->{nextnick} = 0;
  $heap->{connected} = 0;
  $heap->{serverlink} = "";
  $heap->{starttime} = time();
}

sub _stop {
  my ($kernel, $heap, $quitmsg) = @_[KERNEL, HEAP, ARG0];

  if ($heap->{connected}) {
    $kernel->call( $_[SESSION], 'shutdown', $quitmsg );
  }
}

# Disconnect the IRC Service from IRC Network

sub squit {
  my ($kernel, $heap) = @_[KERNEL,HEAP];

  # Don't give a f**k about any parameters passed

  if ( $heap->{'socket'} ) {
    delete ( $heap->{'socket'} );
  }
#  $kernel->call( $_[SESSION], 'shutdown' );
}

# Connect to IRC Network

sub connect {
  my ($kernel, $heap, $session) = @_[KERNEL, HEAP, SESSION];

  if ($heap->{'socket'}) {
        $kernel->call ($session, 'squit');
  }

  $heap->{socketfactory} = POE::Wheel::SocketFactory->new(
                                        SocketDomain => AF_INET,
                                        SocketType => SOCK_STREAM,
                                        SocketProtocol => 'tcp',
                                        RemoteAddress => $heap->{'remoteserver'},
                                        RemotePort => $heap->{'serverport'},
                                        SuccessEvent => '_sock_up',
                                        FailureEvent => '_sock_failed',
                                        ( $heap->{localaddr} ? (BindAddress => $heap->{localaddr}) : () ),
  );

}

# Internal function called when a socket is closed.
sub _sock_down {
  my ($kernel, $heap) = @_[KERNEL, HEAP];

  # Destroy the RW wheel for the socket.
  delete $heap->{'socket'};
  $heap->{connected} = 0;

  # post a 'irc_disconnected' to each session that cares
  foreach (keys %{$heap->{sessions}}) {
    $kernel->post( $heap->{sessions}->{$_}->{'ref'},
                   'irc_p10_disconnected', $heap->{server} );
  }
}

sub _sock_up {
  my ($kernel,$heap,$session,$socket) = @_[KERNEL,HEAP,SESSION,ARG0];
  $heap->{connecttime} = time();
  $heap->{State}->_burst_create();

  delete $heap->{socketfactory};

  $heap->{localaddr} = (unpack_sockaddr_in( getsockname $socket))[1];

  $heap->{'socket'} = new POE::Wheel::ReadWrite
  (
        Handle => $socket,
        Driver => POE::Driver::SysRW->new(),
        Filter => POE::Filter::Line->new(),
        InputEvent => '_parseline',
        ErrorEvent => '_sock_down',
   );

  if ($heap->{'socket'}) {
        $heap->{connected} = 1;
  } else {
        _send_event ( $kernel, $heap, 'irc_p10_socketerr', "Couldn't create ReadWrite wheel for IRC socket" );
  }

  foreach (keys %{$heap->{sessions}}) {
        $kernel->post( $heap->{sessions}->{$_}->{'ref'}, 'irc_p10_connected', $heap->{remoteserver}, $heap->{servernum} );
  }

  $heap->{socket}->put("PASS $heap->{password}\n");
  $heap->{socket}->put("SERVER $heap->{servername} 1 $heap->{starttime} $heap->{connecttime} J10 $heap->{servernum}A]] 0 :$heap->{serverdesc}\n");
  # Sit back and wait for the uplink to finish its burst
}

sub _sock_failed {
  my ($kernel, $heap, $op, $errno, $errstr) = @_[KERNEL, HEAP, ARG0..ARG2];

  _send_event( $kernel, $heap, 'irc_p10_socketerr', "$op error $errno: $errstr" );
}

# Parse each line from received at the socket

# Parse a message from the IRC server and generate the appropriate
# event(s) for listening sessions.
sub _parseline {
  my ($kernel, $session, $heap, $line) = @_[KERNEL, SESSION, HEAP, ARG0];
  my (@events, @cooked);

  # Feed the proper Filter object the raw IRC text and get the
  # "cooked" events back for sending, then deliver each event. We
  # handle CTCPs separately from normal IRC messages here, to avoid
  # silly module dependencies later.

  @cooked = ($line =~ tr/\001// ? @{$heap->{ctcp_filter}->get( [$line] )}
             : @{$heap->{irc_filter}->get( [$line] )} );

  foreach my $ev (@cooked) {
    $ev->{name} = 'irc_p10_' . $ev->{name};
    _send_event( $kernel, $heap, $session, $ev->{name}, @{$ev->{args}} );
  }
}


# Sends an event to all interested sessions. This is a separate sub
# because I do it so much, but it's not an actual POE event because it
# doesn't need to be one and I don't need the overhead.
# BinGOs: Added a hack to try and improve performance for IRC Service
#         use a CALL instead of a POST if the session ID is our own
sub _send_event  {
  my ($kernel, $heap, $session, $event, @args) = @_;
  my %sessions;

  foreach (values %{$heap->{events}->{'irc_p10_all'}},
           values %{$heap->{events}->{$event}}) {
    $sessions{$_} = $_;
  }
  # Make sure our session gets notified of any requested events before any other bugger
  $kernel->call( $session, $event, @args ) if ( defined ($sessions{$session}) );
  foreach (values %sessions) {
    $kernel->post( $_, $event, @args ) unless ( $_ eq $session );
  }
}

sub addnick {
  my ($kernel, $heap, $session, $args) = @_[KERNEL, HEAP, SESSION, ARG0];
  my $connecttime = time();

  if ($args) {
    my %arg;
    if (ref $args eq 'HASH') {
      %arg = %$args;
    } else {
      die "First argument to addnick() should be a hash reference";
    }

    # Gentlemen, lets get down to business
    # Mandatory fields we must must must have these, damnit
    my $nickname = $arg{'NickName'} if exists $arg{'NickName'};
    my $username = $arg{'UserName'} if exists $arg{'UserName'};
    my $hostname = $arg{'HostName'} if exists $arg{'HostName'};
    my $authname = $arg{'AuthName'} if exists $arg{'AuthName'};
    my $umode = $arg{'Umode'} if exists $arg{'Umode'};
    my $description = $arg{'Description'} if exists $arg{'Description'};
    my $localaddr = $arg{'LocalAddr'} if exists $arg{'LocalAddr'};

    unless (defined $nickname) {
	die "You must specify at least a NickName to addnick";
    }

    # Check if NickName already exists. Issue a KILL if it does and call addnick again with a delay
    if (not $heap->{State}->nick_numeric($nickname) ) {

      my $numeric = dectobase64($heap->{nextnick},3);
      $heap->{nextnick}++;

      # Default everything else

      my $cmd = "N $nickname 1 $connecttime ";
      $cmd .= lc $nickname . " " unless (defined $username);
      $cmd .= "$username " if (defined $username);
      $cmd .= "$heap->{servername} " unless (defined $hostname);
      $cmd .= "$hostname " if (defined $hostname);
      $umode = "+odk" unless (defined $umode);
      $umode = "+" . $umode unless ($umode =~ /^\+/ or not defined $umode);
      $umode .= "r" unless (not defined $authname or $umode =~ /r/);
      $authname = $nickname unless (defined $authname or $umode !~ /r/);
      $umode .= " $authname" unless (not defined $authname or $umode !~ /r/);
      $description = $heap->{serverdesc} unless (defined $description);
      $localaddr = "127.0.0.1" unless (defined $localaddr);

      $localaddr = inttobase64($localaddr);

      $cmd .= "$umode $localaddr $heap->{servernum}$numeric :$description";

      $kernel->yield ( 'sl_server', $cmd );

    } else {
      # Issue the KILL ... bye bye sucker!
      my ($target) = $heap->{State}->nick_numeric($nickname);
      $kernel->yield ( 'sl_server', $cmd2token{'KILL'} . " $target :" . $heap->{servername} . " (Using a Services nickname)" );
      $kernel->delay ( 'addnick' => 5 => \%arg );
    }

  } else {
      die "First argument to addnick() should be a hash or array reference";
  }

}

# Deal with STATS requests

sub irc_p10_stats {
  my ($kernel,$heap,$who,$what) = @_[KERNEL,HEAP,ARG0,ARG1];

  my ($first,undef) = split(/ :/,$what,2);
  SWITCH: {
    if ($first eq "u") {
	my ($string) = timestring($heap->{starttime});
	my ($clients) = $heap->{State}->server_clients($heap->{servernum});
	$kernel->yield( 'sl_server', "242 $who :$string" );
	$kernel->yield( 'sl_server', "250 $who :Highest connection count: " . ( $clients + 1 ) . " ($clients clients)" );
	$kernel->yield( 'sl_server', "219 $who $first :End of /STATS report" );
	last SWITCH;
    }
  }
}

# Remove client if we get a quit for it

sub irc_p10_quit {
  my ($heap, $who) = @_[HEAP,ARG0];

  $heap->{State}->_nick_del($who);
}

# Or if it is killed

sub irc_p10_kill {
  my ($heap, $who, $what) = @_[HEAP,ARG0,ARG1];

  $heap->{State}->_nick_del(substr($what,0,5));
}

# Server related handlers
# Who is our uplink ... needed so that we don't respond to every single EOB

sub irc_p10_server_link {
  my ($heap, @args) = @_[HEAP,ARG0 .. $#_];

  $heap->{serverlink} = substr($args[5],0,2);
  $heap->{State}->{serverlink} = $heap->{serverlink};
  $heap->{State}->_server_add($heap->{serverlink},$args[0],$args[1],$heap->{servernum});
}

sub irc_p10_server {
  my ($heap, $what, $args) = @_[HEAP,ARG0,ARG1];

  my ($first,$second) = split(/ :/,$args);
  my (@args) = split(/ /,$first);
  $heap->{State}->_server_add(substr($args[5],0,2),$args[0],$args[1],$what);
}

sub irc_p10_squit {
  my ($heap, $what, $args) = @_[HEAP,ARG0,ARG1];

  my ($first,$second) = split(/ :/,$args);
  my (@args) = split(/ /,$first);
  my ($who) = $heap->{State}->server_numeric($args[0]);
  if ($who eq $heap->{servernum}) {
    $_[KERNEL]->delay( 'autoping' => undef );
    $who = $heap->{serverlink};
  }
  $heap->{State}->_server_del($who);
}

sub irc_p10_disconnected {
  my ($kernel,$heap) = @_[KERNEL,HEAP];

  if ( $heap->{Reconnect} ) {
    $kernel->yield( 'connect' );
  }
}

sub irc_p10_socketerr {
  my ($kernel,$heap) = @_[KERNEL,HEAP];

  if ( $heap->{Reconnect} ) {
    $kernel->yield( 'connect' );
  }
}

sub irc_p10_version {
  my ($kernel, $heap, $who) = @_[KERNEL,HEAP,ARG0];

  $kernel->yield( 'sl_server', "351 $who $heap->{version}. $heap->{servername} :" );
}

# Generate an automatic pong in response to IRC Server's ping

sub irc_p10_ping {
  my ($kernel, $heap, $arg) = @_[KERNEL, HEAP, ARG0];

  $kernel->yield( 'sl_server', "$cmd2token{PONG} $arg") unless ( $arg eq $heap->{servernum} );
}

# Generate an automatic end_of_burst_ack in response to IRC Server's end_of_burst. It's only polite of course :)

sub irc_p10_end_of_burst {
  my ($kernel, $heap, $arg) = @_[KERNEL, HEAP, ARG0];

  if ($arg eq $heap->{serverlink}) {
    $kernel->yield( 'sl_server', "$cmd2token{EOB_ACK}");
    # Now we burst our shit to the uplink
    foreach ($heap->{State}->_burst_info()) {
        $kernel->yield( 'sl_server', $_ );
    }
    $kernel->yield( 'sl_server', "$cmd2token{END_OF_BURST}" );
    $heap->{State}->_burst_destroy();
  }
}

sub irc_p10_eob_ack {
  my ($kernel,$heap) = @_[KERNEL,HEAP];

  # Lazy, but we can assume that it is our uplink that ACK'ed
  # Start PINGing uplink server

  $kernel->yield( 'autoping' );
}

sub autoping {
  my ($kernel,$heap) = @_[KERNEL,HEAP];

  if ( $heap->{'socket'} ) {
    my ($uplink) = $heap->{State}->server_name($heap->{serverlink});
    my ($seconds,$micro) = gettimeofday();

    $kernel->yield( 'sl_server', "G !$seconds.$micro $uplink $seconds.$micro" );
    $kernel->delay( 'autoping' => $heap->{pingfreq} );
  }
}

sub irc_p10_whois {
  my ($kernel,$heap,$who,$what) = @_[KERNEL,HEAP,ARG0,ARG1];
  my ($target) = ( split /:/,$what )[1];

  my ($numeric) = $heap->{State}->nick_numeric($target);
  my (@info) = $heap->{State}->nick_info($numeric);

  $kernel->yield( 'sl_server' => "311 $who $info[0] " . $info[1] . " $info[2] * :$info[3]" );
  if ( defined ( $heap->{his_servername} ) and defined ( $heap->{his_serverinfo} ) and not $heap->{State}->is_operator($who) ) {
    $kernel->yield( 'sl_server' => "312 $who $info[0] $heap->{his_servername} :$heap->{his_serverinfo}" );
  } else {
    $kernel->yield( 'sl_server' => "312 $who $info[0] $heap->{servername} :$heap->{serverdesc}" );
  }
  $kernel->yield( 'sl_server' => "313 $who $info[0] :is an IRC Operator" ) if ( $info[4] =~ /o/ );
  $kernel->yield( 'sl_server' => "330 $who $info[0] $info[5] :is authed as" ) if ( defined ($info[5]) );
  $kernel->yield( 'sl_server' => "317 $who $info[0] 0 $heap->{starttime} :seconds idle, signon time" );
  $kernel->yield( 'sl_server' => "318 $who $info[0] :End of /WHOIS list." );
}

# Track New Nicks and Nick Changes

sub irc_p10_nick {
  my ($kernel, $heap, $who) = @_[KERNEL,HEAP,ARG0];

  # New nick on the network or a burst
  if ($who =~ /^.{2}$/) {
    my ($oper,$authname);
    my ($first,$second) = split(/ :/,$_[ARG1],2);
    my (@args) = split(/ /,$first);
    if ($args[5] =~ /^\+([a-zA-Z]+)/) {
       $oper = $1;
       if ($args[5] =~ /r/) {
          $authname = $args[6];
       }
    }
    $heap->{State}->_nick_add($args[$#args],$args[0],$args[3],$args[4],$args[$#args-1],$args[2],$oper,$authname,$second);

  # Or a user changed their nick
  } else {
    my ($first,undef) = split(/ /,$_[ARG1]);
    $heap->{State}->_nick_change($who,$first);
  }

}

sub irc_p10_account {
  my ($kernel, $heap, $what) = @_[KERNEL,HEAP,ARG1];

  my ($who,$account) = split(/ /,$what);
  # Strip any leading colons
  $account =~ s/^://;
  $heap->{State}->_nick_account($who,$account);
}

sub irc_p10_burst {
  my ($kernel,$heap,$who,$what) = @_[KERNEL,HEAP,ARG0,ARG1];

  $heap->{State}->_channel_burst($who,$what);
}

sub irc_p10_create {
  my ($kernel,$heap,$who,$what) = @_[KERNEL,HEAP,ARG0,ARG1];

  my ($channel,$timestamp) = split(/ /,$what);
  $heap->{State}->_channel_join($channel,$who,$timestamp);
}

sub irc_p10_join {
  my ($kernel,$heap,$who,$what) = @_[KERNEL,HEAP,ARG0,ARG1];

  my ($channel,$timestamp) = split(/ /,$what);
  $heap->{State}->_channel_join($channel,$who,$timestamp);
}

sub irc_p10_part {
  my ($kernel,$heap,$who,$what) = @_[KERNEL,HEAP,ARG0,ARG1];

  my ($channel,undef) = split(/ :/,$what);
  $heap->{State}->_channel_part($channel,$who);
}

sub irc_p10_kick {
  my ($kernel,$heap,$who,$channel,$victim) = @_[KERNEL,HEAP,ARG0,ARG1,ARG2];

  $heap->{State}->_channel_part($channel,$victim);
}

sub irc_p10_mode {
  my ($kernel,$heap,$who,$what,$mode) = @_[KERNEL,HEAP,ARG0,ARG1,ARG2];

  # Assume that if it isnt a channel its a umode change
  if ($what !~ /^#/) {
    $heap->{State}->_nick_umode($who,$mode);
  } else {
    # Okay its a channel mode
    if ( $heap->{eventmode} ) {
      my ($args) = join(" ",@_[ARG3..$#_]);
      $mode .= " " . $args if ( defined ($args) );
      $heap->{State}->_channel_mode($what,$mode,$who);
    }
  }
}

sub irc_p10_opmode {
  my ($kernel,$heap,$who,$what,$mode) = @_[KERNEL,HEAP,ARG0,ARG1,ARG2];

  # Assume that if it isnt a channel its a umode change
  if ($what !~ /^#/) {
    $heap->{State}->_nick_umode($who,$mode);
  } else {
    # Okay its a channel mode
    my ($args) = join(" ",@_[ARG3..$#_]);
    $mode .= " " . $args if ( defined ($args) );
    $heap->{State}->_channel_mode($what,$mode,$who);
  }
}

sub irc_p10_clearmode {
  my ($kernel,$heap,$who,$what) = @_[KERNEL,HEAP,ARG0,ARG1];

  my ($channel,$flags) = split(/ /,$what);
  $heap->{State}->_channel_clearmode($channel,$flags);
}

# Our event handlers for events sent to us

# The handler for commands which have N arguments, separated by commas.
sub commasep {
  my ($kernel, $state) = @_[KERNEL, STATE];
  my $args = join ',', @_[ARG0 .. $#_];

  $state = $cmd2token{uc( $state )};
  $state .= " $args" if defined $args;
  $kernel->yield( 'sl_server', $state );
}

# The handler for commands which have N arguments, separated by commas. Client hacked.
sub commasep_client {
  my ($kernel, $state, $numeric) = @_[KERNEL, STATE, ARG0];
  my $args = join ',', @_[ARG1 .. $#_];

  $state = $cmd2token{uc( $state )};
  $state .= " $args" if defined $args;
  $kernel->yield( 'sl_client', "$numeric $state" );
}

# Send a CTCP query or reply, with the same syntax as a PRIVMSG event.
sub ctcp {
  my ($kernel, $state, $heap, $numeric, $to) = @_[KERNEL, STATE, HEAP, ARG0, ARG1];
  my $message = join ' ', @_[ARG2 .. $#_];

  unless (defined $numeric and defined $to and defined $message) {
    die "The POE::Component::IRC event \"$state\" requires three arguments";
  }

  # CTCP-quote the message text.
  ($message) = @{$heap->{ctcp_filter}->put([ $message ])};

  # Should we send this as a CTCP request or reply?
  $state = $state eq 'ctcpreply' ? 'notice' : 'privmsg';

  $kernel->yield( $state, $numeric, $to, $message );
}

# Tell the IRC server to forcibly remove a user from a channel.
sub kick {
  my ($kernel, $numeric, $chan, $nick) = @_[KERNEL, ARG0, ARG1, ARG2];
  my $message = join '', @_[ARG3 .. $#_];

  unless (defined $numeric and defined $chan and defined $nick) {
    die "The POE::Component::IRC event \"kick\" requires at least three arguments";
  }

  $nick .= " :$message" if defined $message;
  $kernel->yield('sl_client', "$numeric K $chan $nick" );
}

# The handler for all IRC commands that take no arguments.
sub noargs {
  my ($kernel, $state, $arg) = @_[KERNEL, STATE, ARG0];

  if (defined $arg) {
    die "The POE::Component::IRC event \"$state\" takes no arguments";
  }
  $kernel->yield( 'sl_server', $cmd2token{uc( $state )} );
}

# The handler for all IRC commands that take no arguments. Client hacked.
sub noargs_client {
  my ($kernel, $state, $numeric, $arg) = @_[KERNEL, STATE, ARG0, ARG1];

  unless (defined $numeric) {
    die "The POE::Component::IRC event \"$state\" requires at least one argument";
  }

  if (defined $arg) {
    die "The POE::Component::IRC event \"$state\" takes no arguments";
  }
  $kernel->yield( 'sl_client', "$numeric " . $cmd2token{uc( $state )} );
}

# The handler for commands that take one required and two optional arguments.
sub oneandtwoopt {
  my ($kernel, $state) = @_[KERNEL, STATE];
  my $arg = join '', @_[ARG0 .. $#_];

  $state = $cmd2token{uc( $state )};
  if (defined $arg) {
    $arg = ':' . $arg if $arg =~ /\s/;
    $state .= " $arg";
  }
  $kernel->yield( 'sl_server', $state );
}

# The handler for commands that take one required and two optional arguments. Client hacked.
sub oneandtwoopt_client {
  my ($kernel, $state, $numeric) = @_[KERNEL, STATE, ARG0];
  my $arg = join '', @_[ARG1 .. $#_];

  unless (defined $numeric) {
    die "The POE::Component::IRC event \"$state\" requires at least one argument";
  }

  $state = $cmd2token{uc( $state )};
  if (defined $arg) {
    $arg = ':' . $arg if $arg =~ /\s/;
    $state .= " $arg";
  }
  $kernel->yield( 'sl_client', "$numeric $state" );
}

# The handler for commands that take at least one optional argument.
sub oneoptarg {
  my ($kernel, $state) = @_[KERNEL, STATE];
  my $arg = join '', @_[ARG0 .. $#_] if defined $_[ARG0];

  $state = $cmd2token{uc( $state )};
  if (defined $arg) {
    $arg = ':' . $arg if $arg =~ /\s/;
    $state .= " $arg";
  }
  $kernel->yield( 'sl_server', $state );
}

# The handler for commands that take at least one optional argument. Client hacked.
sub oneoptarg_client {
  my ($kernel, $state, $numeric) = @_[KERNEL, STATE, ARG0];
  my $arg = join '', @_[ARG1 .. $#_] if defined $_[ARG1];

  unless (defined $numeric) {
    die "The POE::Component::IRC event \"$state\" requires at least one argument";
  }

  $state = $cmd2token{uc( $state )};
  if (defined $arg) {
    $arg = ':' . $arg if $arg =~ /\s/;
    $state .= " $arg";
  }
  $kernel->yield( 'sl_client', "$numeric $state" );
}

# The handler for commands which take one required and one optional argument.
sub oneortwo {
  my ($kernel, $state, $one) = @_[KERNEL, STATE, ARG0];
  my $two = join '', @_[ARG1 .. $#_];

  unless (defined $one) {
    die "The POE::Component::IRC event \"$state\" requires at least one argument";
  }

  $state = $cmd2token{uc( $state )} . " $one";
  $state .= " $two" if defined $two;
  $kernel->yield( 'sl_server', $state );
}

# The handler for commands which take one required and one optional argument. Client hacked.
sub oneortwo_client {
  my ($kernel, $state, $numeric, $one) = @_[KERNEL, STATE, ARG0, ARG1];
  my $two = join '', @_[ARG2 .. $#_];

  unless (defined $numeric and defined $one) {
    die "The POE::Component::IRC event \"$state\" requires at least two argument";
  }

  $state = $cmd2token{uc( $state )} . " $one";
  $state .= " $two" if defined $two;
  $kernel->yield( 'sl_client', "$numeric $state" );
}

# Handler for commands that take exactly one argument.
sub onlyonearg {
  my ($kernel, $state) = @_[KERNEL, STATE];
  my $arg = join '', @_[ARG0 .. $#_];

  unless (defined $arg) {
    die "The POE::Component::IRC event \"$state\" requires one argument";
  }

  $state = $cmd2token{uc( $state )};
  $arg = ':' . $arg if $arg =~ /\s/;
  $state .= " $arg";
  $kernel->yield( 'sl_server', $state );
}

# Handler for commands that take exactly one argument. Client hacked.
sub onlyonearg_client {
  my ($kernel, $state, $numeric) = @_[KERNEL, STATE, ARG0];
  my $arg = join '', @_[ARG1 .. $#_];

  unless (defined $numeric and defined $arg) {
    die "The POE::Component::IRC::Service::P10 event \"$state\" requires two argument";
  }

  $state = $cmd2token{uc( $state )};
  $arg = ':' . $arg if $arg =~ /\s/;
  $state .= " $arg";
  $kernel->yield( 'sl_client', "$numeric $state" );
}

# Handler for commands that take exactly two arguments.
sub onlytwoargs {
  my ($heap, $kernel, $state, $one) = @_[HEAP, KERNEL, STATE, ARG0];
  my ($two) = join '', @_[ARG1 .. $#_];

  unless (defined $one and defined $two) {
    die "The POE::Component::IRC::Service::P10 event \"$state\" requires two arguments";
  }

  $state = $cmd2token{uc( $state )};
  $two = ':' . $two if $two =~ /\s/;
  $kernel->yield( 'sl_server', "$state $one $two" );
}

# Handler for commands that take exactly two arguments. Client hacked.
sub onlytwoargs_client {
  my ($heap, $kernel, $state, $numeric, $one) = @_[HEAP, KERNEL, STATE, ARG0, ARG1];
  my ($two) = join '', @_[ARG2 .. $#_];

  unless (defined $numeric and defined $one and defined $two) {
    die "The POE::Component::IRC::Service::P10 event \"$state\" requires three arguments";
  }

  $state = $cmd2token{uc( $state )};
  $two = ':' . $two if $two =~ /\s/;
  $kernel->yield( 'sl_client', "$numeric $state $two" );
}

# Handler for privmsg or notice events.
sub privandnotice {
  my ($kernel, $state, $numeric, $to) = @_[KERNEL, STATE, ARG0, ARG1];
  my $message = join ' ', @_[ARG2 .. $#_];

  unless (defined $numeric and defined $to and defined $message) {
    die "The POE::Component::IRC event \"$state\" requires three arguments";
  }

  if (ref $to eq 'ARRAY') {
    $to = join ',', @$to;
  }

  $state = $cmd2token{uc( $state )};
  $state .= " $to :$message";
  $kernel->yield( 'sl_client', "$numeric $state" );
}

# Tell the IRC session to go away.
sub shutdown {
  my ($kernel, $heap) = @_[KERNEL, HEAP];

  foreach ($kernel->alias_list( $_[SESSION] )) {
    $kernel->alias_remove( $_ );
  }

  foreach (qw(socket sock socketfactory dcc wheelmap)) {
    delete $heap->{$_};
  }
}

# The handler for commands which have N arguments, separated by spaces.
sub spacesep {
  my ($kernel, $state) = @_[KERNEL, STATE];
  my $args = join ' ', @_[ARG0 .. $#_];

  $state = $cmd2token{uc( $state )};
  $state .= " $args" if defined $args;
  $kernel->yield( 'sl_server', $state );
}

# The handler for commands which have N arguments, separated by spaces. Client hacked.
sub spacesep_client {
  my ($kernel, $state, $numeric) = @_[KERNEL, STATE, ARG0];
  my $args = join ' ', @_[ARG1 .. $#_];

  $state = $cmd2token{uc( $state )};
  $state .= " $args" if defined $args;
  $kernel->yield( 'sl_server', "$numeric $state" );
}

# Dish out server initiated commands

sub sl_server {
  my ($kernel, $heap, $cmd) = @_[KERNEL, HEAP, ARG0];

  # TODO: need to categorise events so that we don't send crap to the uplink
  # eg. if we send events to our clients
  # TBH I don't suppose the uplink cares that much :o)

  $heap->{socket}->put("$heap->{servernum} $cmd\n") if ( $heap->{'socket'} );
  $kernel->yield('_parseline',"$heap->{servernum} $cmd");
}

# Dish out client (whichever is specified) initiated commands

sub sl_client {
  my ($kernel, $heap, $cmd) = @_[KERNEL, HEAP, ARG0];

  $heap->{socket}->put("$cmd\n") if ($heap->{'socket'});
  $kernel->yield('_parseline',$cmd);
}

# Set or query the current topic on a channel.
sub topic {
  my ($kernel,$heap, $numeric, $chan) = @_[KERNEL,HEAP, ARG0, ARG1];
  my $topic = join '', @_[ARG2 .. $#_];

  $chan .= " :$topic" if length $topic;
  $kernel->yield('sl_client',"$numeric T $chan");
}

# Base64 P10 Stylee functions

# Convert decimal to Base64 optionally provide the length of the Base64 returned
sub dectobase64 {
  my ($number) = shift || 0;
  my ($output) = shift || 2;
  my ($numeric) = "";

  if ($number == 0) {
    for (my $i = length($numeric); $i < $output; $i++) {
      $numeric = "A" . $numeric;
    }
    return $numeric;
  }

  my ($b64chars) = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789[]";
  my (@d2b64) = split(//,$b64chars);

  my (@convert); my ($g); my ($r);

  LOOP: while (1) {
    $g = $number / 64;
    $r = $number % 64;
    if ($g >= 64) {
        $number = $g;
        push(@convert,$r);
    } else {
        push(@convert,$r);
        push(@convert,int $g);
        last LOOP;
    }
  }
  foreach (reverse @convert) {
    $numeric .= $d2b64[$_];
  }
  for (my $i = length($numeric); $i < $output; $i++) {
    $numeric = "A" . $numeric;
  }
  return $numeric;
}

# Convert from Base64 to decimal
sub base64todec {
  my ($numeric) = shift || return undef;

  my ($b64chars) = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789[]";
  my (@d2b64) = split(//,$b64chars);
  my (%b642d) = ();
  for (my $i = 0; $i <= $#d2b64; $i++) {
    $b642d{$d2b64[$i]} = $i;
  }

  my (@numeric) = reverse split(//,$numeric);
  my ($number) = 0;

  for (my $i=0; $i <= $#numeric; $i++) {
        $number += (64**$i) * $b642d{$numeric[$i]};
  }
  return $number;
}

# Convoluted method to convert from IP quad to Base64 /me *sighs*
sub inttobase64 {
  my ($quad) = shift || return undef;

  return dectobase64(hex(int2hex(dotq2int($quad))));
}

# The following two functions are taken from :-
# http://www.math.ucla.edu/~jimc/jvtun
# Copyright © 2003 by James F. Carter.  2003-08-02, Perl-5.8.0

sub dotq2int {
    my @dotq = split /[.\/]/, $_[0];
    push(@dotq, 32) if @dotq == 4;
    my($ip) = unpack("N", pack("C4", splice(@dotq, 0, 4)));
    my($mask) = (@dotq > 1) ? unpack("N", pack("C4", @dotq)) :
        $dotq[0] ? ~((1 << (32-$dotq[0]))-1) : 0;

    ($ip, $mask);
}

sub int2hex {
    sprintf("%08X", $_[0]);
}

# Our own little function to return a proper uppercase nickname or channel name IRC stylee
# See the RFC for the details

sub u_irc {
  my ($value) = shift || return undef;

  $value =~ tr/a-z{}|/A-Z[]\\/;
  return $value;
}


# Return a correctly formatted string for STATS u requests

sub timestring {
      my ($timeval) = shift || return 0;
      my $uptime = time() - $timeval;

      my $days = int $uptime / 86400;
      my $remain = $uptime % 86400;
      my $hours = int $remain / 3600;
      $remain %= 3600;
      my $mins = int $remain / 60;
      $remain %= 60;
      return sprintf("Server Up %d days, %2.2d:%2.2d:%2.2d",$days,$hours,$mins,$remain);
}

sub retOpflags {
  my ($opflags) = shift || return undef;
  my (@opflags) = ();
  my ($action) = "";

  for (my $i = 0; $i < length($opflags); $i++) {
    my $char = substr($opflags,$i,1);
    if ($char eq "+" or $char eq "-") {
       $action = $char;
    } else {
       push (@opflags,"$action$char");
    }
  }
  return @opflags;
}

# Object Methods
# Private methods begin with _

sub _server_add {
  my ($self) = shift;

  my ($server) = { Numeric => $_[0],
		   Name    => $_[1],
		   Hops    => $_[2],
		   Link    => $_[3]
		 };

  $self->{servers_numeric}->{ $server->{Numeric} } = $server;
  $self->{servers_name}->{ $server->{Name} } = $server;
  return 1;
}

sub _server_del {
  my ($self) = shift;
  my ($server) = shift || return 0;

  $self->{servers_numeric}->{$server}->{ToDelete} = 1;
  foreach ( keys %{ $self->{servers_numeric} } ) {
    if ( $server eq $self->{servers_numeric}->{$_}->{Link} and not defined ( $self->{servers_numeric}->{$server}->{ToDelete}) ) {
       $self->_server_del($self->{servers_numeric}->{$_}->{Link});
    }
  }
  my (@numerics) = grep /^$server/, keys %{ $self->{bynumeric} };
  foreach (@numerics) {
    $self->_nick_del($_);
  }
  my ($servername) = $self->{servers_numeric}->{$server}->{Name};
  delete ( $self->{servers_numeric}->{$server} );
  delete ( $self->{servers_name}->{$servername} );
  return 1;
}

sub _nick_add {
  my ($self) = shift;
  my ($numeric) = $_[0] || return 0;
  my ($nickname) = $_[1] || return 0;
  my ($username) = $_[2] || return 0;
  my ($hostname) = $_[3] || return 0;
  my ($ipaddr) = $_[4] || return 0;
  my ($timestamp) = $_[5] || time();
  my ($umode) = $_[6] || undef;
  my ($authname) = $_[7] || undef;
  my ($ircname) = $_[8] || undef;

  # Does the nickname already exist in our state, ie. one of our clients
  # If so kludge the timestamp on ours so it is older and they will get KILLed mwuahahahaha :o)
  if ( defined ( $self->{bynickname}->{ u_irc ($nickname) } ) ) {
    my ($kludge) = $timestamp - 30;
    $self->{bynickname}->{ u_irc ( $nickname ) }->{TimeStamp} = $kludge;
    if ( defined ( $self->{burst_nicks}->{ $self->{bynickname}->{ u_irc ( $nickname ) }->{Numeric} } ) ) {
      $self->{burst_nicks}->{ $self->{bynickname}->{ u_irc ( $nickname ) }->{Numeric} }->{TimeStamp} = $kludge;
    }
  }

  if ( not defined ( $self->{bynumeric}->{$numeric} ) ) {
    my ($record) = { Numeric => $numeric,
  		     NickName => $nickname,
		     UserName => $username,
		     HostName => $hostname,
		     IRCName => $ircname,
		     IPAddr => $ipaddr,
		     TimeStamp => $timestamp,
		     UMode => $umode,
		     AuthName => $authname };
    $self->{bynumeric}->{ $record->{Numeric} } = $record;
    $self->{bynickname}->{ u_irc ( $record->{NickName} ) } = $record;
  }

  return 1;
}

sub _nick_del {
  my ($self) = shift;
  my ($numeric) = shift || return 0;

  foreach ( keys %{ $self->{bynumeric}->{$numeric}->{Channels} } ) {
    delete ( $self->{channels}->{$_}->{Members}->{$numeric} );
    if ( scalar ( keys % { $self->{channels}->{$_}->{Members} } ) == 0 ) {
	delete ( $self->{channels}->{$_} );
    }
  }
  my ($nickname) = u_irc ( $self->{bynumeric}->{$numeric}->{NickName} );
  delete ( $self->{bynumeric}->{$numeric} );
  delete ( $self->{bynickname}->{$nickname} );
  return 1;
}

sub _nick_change {
  my ($self) = shift;
  my ($numeric) = shift || return 0;
  my ($newnick) = shift || return 0;

  my ($currentnick) = u_irc( $self->{bynumeric}->{$numeric}->{NickName} );
  $self->{bynumeric}->{$numeric}->{NickName} = $newnick;
  $self->{bynumeric}->{$numeric}->{TimeStamp} = time();
  my ($record) = $self->{bynumeric}->{$numeric};
  delete $self->{bynickname}->{$currentnick};
  $self->{bynickname}->{ u_irc( $record->{NickName} ) } = $record;
  return 1;
}

sub _nick_account {
  my ($self) = shift;
  my ($numeric) = $_[0] || return 0;
  my ($account) = $_[1] || return 0;

  $self->{bynumeric}->{$numeric}->{AuthName} = $account;
  $self->_nick_umode($numeric,"+r");
}

sub _nick_umode {
  my ($self) = shift;
  my ($numeric) = $_[0] || return 0;
  my ($umode) = $_[1] || return 0;

  my ($currentumode) = $self->{bynumeric}->{$numeric}->{UMode};
  foreach (retOpflags($umode)) {
    SWITCH: {
      if (/^\+(.+)/) {
	if ( not defined ($currentumode) ) {
	  $currentumode = $1;
	} else {
	  $currentumode .= $1;
	  $currentumode = join("",sort(split(//,$currentumode)));
	}
	last SWITCH;
      }
      if (/^-(.+)/) {
	if ( defined ($currentumode) ) {
	  $currentumode =~ s/$1//g;
	}
	last SWITCH;
      }
    }
  }
  if ( defined ($currentumode) and $currentumode ) {
    $self->{bynumeric}->{$numeric}->{UMode} = $currentumode;
  } else {
    delete ( $self->{bynumeric}->{$numeric}->{UMode} );
  }
  return 1;
}

sub _channel_join {
  my ($self) = shift;
  my ($channel) = $_[0] || return 0;
  my ($numeric) = $_[1] || return 0;
  my ($timestamp) = $_[2];
  my ($usermode) = 0;
  my ($channelname) = $channel;
  $channel = u_irc ( $channel );

  if (not exists $self->{channels}->{$channel}) {
    $self->{channels}->{$channel}->{Channel} = $channelname;
    $self->{channels}->{$channel}->{TimeStamp} = $timestamp;
    $usermode = 2;
  }
  $self->{channels}->{$channel}->{Members}->{$numeric} = $usermode;
  $self->{bynumeric}->{$numeric}->{Channels}->{$channel} = $usermode;
  return 1;
}

sub _channel_part {
  my ($self) = shift;
  my ($channel) = $_[0] || return 0;
  my ($numeric) = $_[1] || return 0;
  my ($channelname) = $channel;
  $channel = u_irc ( $channel );

  delete ( $self->{channels}->{$channel}->{Members}->{$numeric} );
  if ( scalar ( keys % { $self->{channels}->{$_}->{Members} } ) == 0 ) {
    delete ( $self->{channels}->{$_} );
  }
  delete ( $self->{bynumeric}->{$numeric}->{Channels}->{$channel} );
  return 1;
}

sub _channel_topic {
  my ($self) = shift;
  my ($channel) = u_irc( $_[0] ) || return 0;
  my ($topic) = $_[1] || return 0;
  my ($set_by) = $_[2] || return 0;
  my ($timestamp) = $_[3] || return 0;

  $self->{channels}->{$channel}->{Topic} = $topic;
  $self->{channels}->{$channel}->{Set_By} = $set_by;
  $self->{channels}->{$channel}->{TopicTS} = $timestamp;
  return 1;
}

sub _channel_untopic {
  my ($self) = shift;
  my ($channel) = u_irc( $_[0] ) || return 0;

  delete ( $self->{channels}->{$channel}->{Topic} );
  delete ( $self->{channels}->{$channel}->{Set_By} );
  delete ( $self->{channels}->{$channel}->{TopicTS} );
  return 1;
}

sub _channel_mode {
  my ($self) = shift;
  my ($channel) = u_irc( $_[0] ) || return 0;
  my ($string) = $_[1] || return 0;
  my ($who) = $_[2] || return 0; # This is either a server or client numeric only used for bans tbh

  my ($modes,@args) = split(/ /,$string);
  my (@modes) = retOpflags($modes);
  my ($currentmode) = $self->{channels}->{$channel}->{Mode};
  foreach (@modes) {
    my $argument;
    $argument = shift(@args) if (/\+[ovbkl]/);
    $argument = shift(@args) if (/-[ovb]/);
    SWITCH: {
      if (/b/) {
	$self->_channel_ban($channel,$_,$argument,$who);
	last SWITCH;
      }
      if (/l/) {
	if (/^\+(.+)/) {
	  $self->{channels}->{$channel}->{ChanLimit} = $argument;
	  $currentmode .= $1;
	} else {
	  delete ( $self->{channels}->{$channel}->{ChanLimit} );
	  $currentmode =~ s/$1//g;
	}
	last SWITCH;
      }
      if (/k/) {
	if (/^\+(.+)/) {
	  $self->{channels}->{$channel}->{ChanKey} = $argument;
	  $currentmode .= $1;
	} else {
	  delete ( $self->{channels}->{$channel}->{ChanKey} );
	  $currentmode =~ s/$1//g;
	}
	last SWITCH;
      }
      if (/[ov]/) {
	my ($value) = 0;
	if (/\+o/) { $value = 2; }
	if (/-o/) { $value = -2; }
	if (/\+v/) { $value = 1; }
	if (/-v/) { $value = -1; }
        $self->{channels}->{$channel}->{Members}->{$argument} += $value;
        $self->{bynumeric}->{$argument}->{Channels}->{$channel} += $value;
	last SWITCH;
      }
      if (/^\+(.+)/) {
	$currentmode .= $1;
	last SWITCH;
      }
      if (/^-(.+)/) {
	$currentmode =~ s/$1//g;
	last SWITCH;
      }
    }
  }
  $self->{channels}->{$channel}->{Mode} = join("",sort(split(//,$currentmode)));
  return 1;
}

sub _channel_clearmode {
  my ($self) = shift;
  my ($channel) = u_irc( $_[0] ) || return 0;
  my ($modes) = $_[1] || return 0;

  my ($currentmodes) = $self->{channels}->{$channel}->{Mode};
  foreach (split(//,$modes)) {
    $currentmodes =~ s/$_//g;
  }
  $self->{channels}->{$channel}->{Mode} = $currentmodes;
  delete ( $self->{channels}->{$channel}->{Bans} ) if ( $modes =~ /b/ );
  foreach ( %{ $self->{channels}->{$channel}->{Members} } ) {
    if ( $modes =~ /o/ and $self->{channels}->{$channel}->{Members}->{$_} > 1 ) {
	$self->{channels}->{$channel}->{Members}->{$_} -= 2;
        $self->{bynumeric}->{$_}->{Channels}->{$channel} = $self->{channels}->{$channel}->{Members}->{$_};
    }
    if ( $modes =~ /v/ and $self->{channels}->{$channel}->{Members}->{$_} > 0 ) {
	$self->{channels}->{$channel}->{Members}->{$_} -= 1;
        $self->{bynumeric}->{$_}->{Channels}->{$channel} = $self->{channels}->{$channel}->{Members}->{$_};
    }
  }
  return 1;
}

sub _channel_ban {
  my ($self) = shift;
  my ($channel) = u_irc( $_[0] ) || return 0;
  my ($operation) = $_[1] || return 0;
  my ($banmask) = $_[2] || return 0;
  my ($who) = $_[3] || return 0;

  if ($operation eq "+b") {
    $self->{channels}->{$channel}->{Bans}->{$banmask}->{Time} = time();
    $self->{channels}->{$channel}->{Bans}->{$banmask}->{Who} = $who;
  } else {
    delete ( $self->{channels}->{$channel}->{Bans}->{$banmask} );
  }
  return 1;
}

sub _channel_burst {
  my ($self) = shift;
  my ($who) = shift;
  my ($args) = shift;

  my ($first,$second) = split(/:%/,$args);
  my (@args) = split(/ /,$first);
  push(@args,":%$second") if ( defined ($second) );
  my ($channelname,$timestamp) = @args[0..1];
  my ($channel) = u_irc ( $channelname );
  # Kludge channel timestamp here
  if ( exists $self->{channels}->{$channel} ) {
    if ( $timestamp < $self->{channels}->{$channel}->{TimeStamp} ) {
	$self->{channels}->{$channel}->{TimeStamp} = $timestamp;
	$self->{burst_channels}->{$channel}->{TimeStamp} = $timestamp;
    }
  } else {
    $self->{channels}->{$channel}->{Channel} = $channelname;
    $self->{channels}->{$channel}->{TimeStamp} = $timestamp;
  }
  my ($channelmodes) = "";
  for (my $i = 2; $i <= $#args; $i++) {
    SWITCH: {
	if ($args[$i] =~ /^\+(.+)/) {
	  $channelmodes = $1;
	  $self->{channels}->{$channel}->{Mode} = $channelmodes;
          my ($l) = index ( $1, "l" );
          my ($k) = index ( $1, "k" );
	  SWITCH2: {
            if ( $l > $k and $k != -1 ) {
	      $i++;
              $self->{channels}->{$channel}->{ChanKey} = $args[$i];
	      $i++;
              $self->{channels}->{$channel}->{ChanLimit} = $args[$i];
              last SWITCH2;
            }
            if ( $l > $k and $k == -1 ) {
	      $i++;
              $self->{channels}->{$channel}->{ChanLimit} = $args[$i];
              last SWITCH2;
            }
            if ( $k > $l and $l != -1 ) {
	      $i++;
              $self->{channels}->{$channel}->{ChanLimit} = $args[$i];
	      $i++;
              $self->{channels}->{$channel}->{ChanKey} = $args[$i];
              last SWITCH2;
            }
            if ( $k > $l and $l == -1 ) {
	      $i++;
              $self->{channels}->{$channel}->{ChanKey} = $args[$i];
              last SWITCH2;
            }
	  }
	  last SWITCH;
	}
	if ($args[$i] =~ /^:%(.+)$/) {
	  foreach (split(/ /,$1)) {
	    $self->_channel_ban($channel,"+b",$_,$who);
	  }
	  last SWITCH;
	}
	# Hey, it must be a list of nicks then :o)
	my ($lastmodes);
	foreach (split(/,/,$args[$i])) {
	  my ($numeric,$modes) = split(/:/);
	  if (defined ($modes)) {
		$lastmodes = $modes;
	  }
	  # Add nick here
	  my ($value) = 0;
	  SWITCH2: {
	    if ( $lastmodes eq "ov" ) {
		$value = 3;
		last SWITCH2;
	    }
	    if ( $lastmodes eq "o" ) {
		$value = 2;
		last SWITCH2;
	    }
	    if ( $lastmodes eq "v" ) {
		$value = 1;
		last SWITCH2;
	    }
          }
	  $self->{channels}->{$channel}->{Members}->{$numeric} = $value;
	  $self->{bynumeric}->{$numeric}->{Channels}->{$channel} = $value;
	}
    }
  }
}

sub _burst_create {
  my ($self) = shift;

  # First a list of nicks
  foreach ( keys %{ $self->{bynumeric} } ) {
    $self->{burst_nicks}->{$_}->{Numeric} = $self->{bynumeric}->{$_}->{Numeric};
    $self->{burst_nicks}->{$_}->{NickName} = $self->{bynumeric}->{$_}->{NickName};
    $self->{burst_nicks}->{$_}->{UserName} = $self->{bynumeric}->{$_}->{UserName};
    $self->{burst_nicks}->{$_}->{HostName} = $self->{bynumeric}->{$_}->{HostName};
    $self->{burst_nicks}->{$_}->{IPAddr} = $self->{bynumeric}->{$_}->{IPAddr};
    $self->{burst_nicks}->{$_}->{UMode} = $self->{bynumeric}->{$_}->{UMode};
    $self->{burst_nicks}->{$_}->{AuthName} = $self->{bynumeric}->{$_}->{AuthName};
    $self->{burst_nicks}->{$_}->{IRCName} = $self->{bynumeric}->{$_}->{IRCName};
    $self->{burst_nicks}->{$_}->{TimeStamp} = $self->{bynumeric}->{$_}->{TimeStamp};
  }
  # And now a list of channels
  foreach ( keys %{ $self->{channels} } ) {
     $self->{burst_channels}->{$_}->{Channel} = $self->{channels}->{$_}->{Channel};
     $self->{burst_channels}->{$_}->{TimeStamp} = $self->{channels}->{$_}->{TimeStamp};
     $self->{burst_channels}->{$_}->{Mode} = $self->{channels}->{$_}->{Mode} if ( exists $self->{channels}->{$_}->{Mode} );
     $self->{burst_channels}->{$_}->{ChanKey} = $self->{channels}->{$_}->{ChanKey} if ( exists $self->{channels}->{$_}->{ChanKey} );
     $self->{burst_channels}->{$_}->{ChanLimit} = $self->{channels}->{$_}->{ChanLimit} if ( exists $self->{channels}->{$_}->{ChanLimit} );
     foreach my $ban ( keys %{ $self->{channels}->{$_}->{Bans} } ) {
	push(@{ $self->{burst_channels}->{$_}->{Bans} },$ban);
     }
     foreach my $user ( keys %{ $self->{channels}->{$_}->{Members} } ) {
	$self->{burst_channels}->{$_}->{Members}->{$user} = $self->{channels}->{$_}->{Members}->{$user};
     }
  }
  return 1;
}

sub _burst_info {
  my ($self) = shift;
  my (@burst);
  my (@mode) = ( "","v","o","ov" );

  # Return an array of correctly formatted lines suitable for spewing at our uplink
  # As per P10 protocol nicks come first
  foreach ( keys %{ $self->{burst_nicks} } ) {
    my ($burstline) = "N " . $self->{burst_nicks}->{$_}->{NickName} . " ";
    $burstline .= "1 " . $self->{burst_nicks}->{$_}->{TimeStamp} . " ";
    $burstline .= $self->{burst_nicks}->{$_}->{UserName} . " " . $self->{burst_nicks}->{$_}->{HostName} . " ";
    $burstline .= "+" . $self->{burst_nicks}->{$_}->{UMode} . " " if ( defined ($self->{burst_nicks}->{$_}->{UMode}) );
    $burstline .= $self->{burst_nicks}->{$_}->{AuthName} . " " if ( defined ($self->{burst_nicks}->{$_}->{AuthName}) );
    $burstline .= $self->{burst_nicks}->{$_}->{IPAddr} . " " . $_ . " :";
    $burstline .= $self->{burst_nicks}->{$_}->{IRCName} if ( defined ($self->{burst_nicks}->{$_}->{IRCName}) );
    push(@burst,$burstline);
  }
  # Followed by channels
  foreach ( keys %{ $self->{burst_channels} } ) {
    my ($burstline) = "B " . $self->{burst_channels}->{$_}->{Channel} . " " . $self->{burst_channels}->{$_}->{TimeStamp} . " ";
    $burstline .= "+" . $self->{burst_channels}->{$_}->{Mode} . " " if ( defined ($self->{burst_channels}->{$_}->{Mode}) );
    $burstline .= $self->{burst_channels}->{$_}->{ChanKey} . " " if ( defined ($self->{burst_channels}->{$_}->{ChanKey}) );
    $burstline .= $self->{burst_channels}->{$_}->{ChanLimit} . " " if ( defined ($self->{burst_channels}->{$_}->{ChanLimit}) );
    my ($lastmode) = 0; my (@users);
    foreach my $member ( sort { $self->{burst_channels}->{$_}->{Members}->{$a} <=> $self->{burst_channels}->{$_}->{Members}->{$b} } keys %{ $self->{burst_channels}->{$_}->{Members} } ) {
      my ($user) = $member;
      if ($self->{burst_channels}->{$_}->{Members}->{$member} > $lastmode) {
	$user .= ":" . $mode[$self->{burst_channels}->{$_}->{Members}->{$member}];
      }
      push(@users,$user);
    }
    $burstline .= join(",",@users) . " ";
    my ($bans) = join(" ",@{ $self->{burst_channels}->{$_}->{Bans} }) if ( defined ($self->{burst_channels}->{$_}->{Bans}) );
    $burstline .= ":%" . $bans if ( defined ($bans) );
    push(@burst,$burstline);
  }
  return @burst;
}

sub _burst_destroy {
  my ($self) = shift;

  delete ( $self->{burst_nicks} );
  delete ( $self->{burst_channels} );
  return 1;
}

sub _dump_state {
  my ($self) = shift;
  my (@mode) = ( '','+','@','@+' );
  my (@results);

  # servers
  foreach ( keys %{ $self->{servers_numeric} } ) {
    push ( @results, $_ . " " . $self->{servers_numeric}->{$_}->{Name} . " " . $self->{servers_numeric}->{$_}->{Hops} . " " . $self->{servers_numeric}->{$_}->{Link} );
  }
  # users
  foreach ( keys %{ $self->{bynumeric} } ) {
    push ( @results, $_ . " " . $self->{bynumeric}->{$_}->{NickName} );
  }
  # channels
  foreach ( keys %{ $self->{channels} } ) {
    my ($line) = $_ . " ";
    foreach my $member ( keys %{ $self->{channels}->{$_}->{Members} } ) {
      $line .= $mode[$self->{channels}->{$_}->{Members}->{$member}] . $self->{bynumeric}->{$member}->{NickName};
    }
    push ( @results, $line );
  }
  return @results;
}

# Public Methods

sub cmd_token {
  my ($self) = shift;
  my ($command) = uc ( $_[0] ) || return undef;

  return $cmd2token{$command};
}

sub server_numeric {
  my ($self) = shift;
  my ($name) = shift || return undef;

  return $self->{servers_name}->{$name}->{Numeric};
}

sub server_name {
  my ($self) = shift;
  my ($numeric) = shift || return undef;

  return $self->{servers_numeric}->{$numeric}->{Name};
}

sub server_clients {
  my ($self) = shift;
  my ($server) = shift || return 0;

  my (@numerics) = grep /^$server/, keys %{ $self->{bynumeric} };

  return scalar( @numerics );
}

sub server_link {
  my ($self) = shift;

  return $self->{serverlink};
}

sub nick_info {
  my ($self) = shift;
  my ($numeric) = shift || return undef;
  my (@returnvalues);

  $returnvalues[0] = $self->{bynumeric}->{$numeric}->{NickName};
  $returnvalues[1] = $self->{bynumeric}->{$numeric}->{UserName};
  $returnvalues[2] = $self->{bynumeric}->{$numeric}->{HostName};
  $returnvalues[3] = $self->{bynumeric}->{$numeric}->{IRCName};
  $returnvalues[4] = $self->{bynumeric}->{$numeric}->{UMode};
  $returnvalues[5] = $self->{bynumeric}->{$numeric}->{AuthName};

  return @returnvalues;
}

sub nick_numeric {
  my ($self) = shift;
  my ($nickname) = u_irc( $_[0] ) || return undef;

  return $self->{bynickname}->{$nickname}->{Numeric};
}

sub nick_name {
  my ($self) = shift;
  my ($numeric) = $_[0] || return undef;

  return $self->{bynumeric}->{$numeric}->{NickName};
}

sub nick_channels {
  my ($self) = shift;
  my ($numeric) = shift || return undef;
  my (@returnvalues);

  foreach ( keys %{ $self->{bynumeric}->{$numeric}->{Channels} } ) {
    SWITCH: {
	if ( $self->{bynumeric}->{$numeric}->{Channels}->{$_} == 1 ) {
	  push(@returnvalues,"+$_");
	  last SWITCH;
	}
	if ( $self->{bynumeric}->{$numeric}->{Channels}->{$_} >= 2 ) {
	  push(@returnvalues,"\@$_");
	  last SWITCH;
	}
	push(@returnvalues,"$_");
    }
  }
  return @returnvalues;
}

sub channel_exists {
  my ($self) = shift;
  my ($channel) = u_irc ( $_[0] ) || return undef;

  if ( defined ( $self->{channels}->{$channel} ) ) {
    return $self->{channels}->{$channel}->{TimeStamp};
  }
  return undef;
}

sub is_channel_operator {
  my ($self) = shift;
  my ($channel) = u_irc ( $_[0] ) || return 0;
  my ($numeric) = $_[1] || return 0;

  if ( defined ( $self->{channels}->{$channel}->{Members}->{$numeric} ) and $self->{channels}->{$channel}->{Members}->{$numeric} >= 2 ) {
    return 1;
  } else {
    return 0;
  }
}

sub has_channel_voice {
  my ($self) = shift;
  my ($channel) = u_irc ( $_[0] ) || return 0;
  my ($numeric) = $_[1] || return 0;

  if ( defined ( $self->{channels}->{$channel}->{Members}->{$numeric} ) and $self->{channels}->{$channel}->{Members}->{$numeric} == 2 or $self->{channels}->{$channel}->{Members}->{$numeric} == 3 ) {
    return 1;
  } else {
    return 0;
  }
}

sub is_operator {
  my ($self) = shift;
  my ($numeric) = $_[0] || return 0;

  if ( defined ( $self->{bynumeric}->{$numeric}->{UMode} ) and $self->{bynumeric}->{$numeric}->{UMode} =~ /o/ ) {
    return 1;
  } else {
    return 0;
  }
}

sub has_account_set {
  my ($self) = shift;
  my ($numeric) = $_[0] || return undef;

  return $self->{bynumeric}->{$numeric}->{AuthName}
}

sub channel_banlist {
  my ($self) = shift;
  my ($channel) = u_irc ( $_[0] ) || return undef;

  return keys %{ $self->{channels}->{$channel}->{Bans} };
}

sub nick_long_form {
  my ($self) = shift;
  my ($numeric) = $_[0] || return undef;

  if ( defined ( $self->{bynumeric}->{$numeric} ) ) {
    return $self->{bynumeric}->{$numeric}->{NickName} . "!" . $self->{bynumeric}->{$numeric}->{UserName} . "\@" . $self->{bynumeric}->{$numeric}->{HostName};
  } else {
    return undef;
  }
}

sub channels_list {
  my ($self) = shift;
  my (@channels);

  foreach ( keys %{ $self->{channels} } ) {
    push (@channels,$self->{channels}->{$_}->{Channel});
  }
  return @channels;
}

sub irc_network_stats {
  my ($self) = shift;
  my (@results);

  # Number of servers
  push (@results,scalar( keys %{ $self->{servers_numeric} } ));
  # Number of users
  push (@results,scalar( keys %{ $self->{bynumeric} } ));
  # Number of channels
  push (@results,scalar( keys %{ $self->{channels} }));
  return @results;
}

sub channel_users {
  my ($self) = shift;
  my ($channel) = u_irc ( $_[0] ) || return undef;

  return keys %{ $self->{channels}->{$channel}->{Members} };
}

sub network_users {
  my ($self) = shift;

  return keys %{ $self->{bynumeric} };
}

sub channel_mode {
  my ($self) = shift;
  my ($channel) = u_irc ( $_[0] ) || return undef;

  return $self->{channels}->{$channel}->{Mode};
}

sub channel_limit {
  my ($self) = shift;
  my ($channel) = u_irc ( $_[0] ) || return undef;

  return $self->{channels}->{$channel}->{ChanLimit};
}

sub channel_key {
  my ($self) = shift;
  my ($channel) = u_irc ( $_[0] ) || return undef;

  return $self->{channels}->{$channel}->{ChanKey};
}

sub decimal_to_base64 {
  my ($self) = shift;
  my ($number) = $_[0] || return undef;
  my ($output) = $_[1] || 2;

  if ( $number =~ /^[0-9]*$/ ) {
    return dectobase64($number,$output);
  } else {
    return undef;
  }
}

sub base64_to_decimal {
  my ($self) = shift;
  my ($base64) = $_[0] || return undef;

  if ( $base64 =~ /^[ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789\[\]]*$/ ) {
    return base64todec($base64);
  } else {
    return undef;
  }
}

# Join a channel. Do a CREATE or JOIN appropriately
sub join {
  my ($kernel,$heap,$numeric,$channel,$modes) = @_[KERNEL,HEAP,ARG0,ARG1,ARG2];

  unless (defined $numeric and defined $channel) {
    die "The POE::Component::IRC event \"join\" requires at least two arguments";
  }

  my ($timestamp) = time();
  if ( $heap->{State}->channel_exists($channel) ) {
    # Join channel
    $kernel->yield( 'sl_client' => "$numeric J $channel $timestamp" );
  } else {
    # Create channel
    $kernel->yield( 'sl_client' => "$numeric C $channel $timestamp" );
  }
}

1;
__END__