=head1 NET::IRC::Server

  NET::IRCServer - a module to handle the IRC Protocol and implements a lightweight IRC Server (without server-to-server support)

=head1 SYNOPSIS

  use NET::IRC::Server;

  $server = NET::IRC::Server->new (srv_prefix => "mein.irc.server.funtzt.net");

  $s->set_send_cb (sub { ... });

  $s->parse_irc_stream (...)

=cut

package Net::IRC::Server;
use Data::Dumper;
use strict;
use warnings;

=head1 METHODS

=over 4

=cut

=item new (srv_prefix => $server_prefix)

  srv_prefix - the prefix the server will use for irc commands from itself

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

=item set_send_cb ($sub)

  The code-ref in the C<$sub> will be called everythime the server wants to send data to a client.
  The callback will be called with following arguments: 
  
  $sub->($client, $data)

  $client - the client datastructure you give C<parse_irc_stream ()>
  $data   - the raw data to send out, for example on a socket

=cut
sub set_send_cb {
  my ($self, $cb) = @_;
  $self->{send_cb} = $cb;
}

sub set_cmd_cb {
  my ($self, $cmd, $cb) = @_;
  $self->{cmd_cbs}->{uc $cmd} = $cb;
}

sub send_msg {
  my ($self, $client, @msg) = @_;
  $self->{send_cb}->($client, $self->mk_msg (@msg));
}

sub mk_msg {
  my ($self, $prefix, $command, $trail, @params) = @_;
  my $msg = "";

  $msg .= defined $prefix ? ":$prefix " : "";
  $msg .= "$command";

  map { $msg .= " $_" } @params;

  $msg .= defined $trail ? " :$trail" : "";
  $msg .= "\r\n";

  return $msg;
}

sub mk_clpref {
  my ($self, $client) = @_;
  return $client->{nickname}."!".$client->{username}.'@'.$client->{hostname};
}

sub parse_irc_stream {
  my ($self, $client, $data) = @_;

  $self->{buffer} .= $data;

  while ($self->{buffer} =~ s/^([^\r\n]*)\r?\n//) {
    push @{$self->{msgs}}, $1;
  }

  map { $self->handle_irc_msg ($client, $self->parse_irc_msg ($_)) } @{$self->{msgs}};

  $self->{msgs} = [];
}

sub handle_irc_msg {
  my ($self, $cl, $msg) = @_;

  return if not defined $msg;

  my $c = $msg->{command};

  my $r;
  $r ||= $self->{cmd_cbs}->{uc $c}->($cl, $msg) if defined $self->{cmd_cbs}->{uc $c};
  $r ||= $self->{cmd_cbs}->{"*"}->($cl, $msg)   if defined $self->{cmd_cbs}->{"*"};

  if ($r) {
    warn "notihgn to do skip srv code\n";
    return 
  }

  if ($c eq "USER") {
    $cl->{username} = $msg->{params}->[0];
    $cl->{realname} = $msg->{params}->[3];
    
  } elsif ($c eq "NICK") {
    my $n = $msg->{params}->[0];
    $self->change_nick ($n, $cl);
  }
  
  if (defined $cl->{username} 
      and defined $cl->{nickname} 
      and not $cl->{registered}) 
  {
    $self->send_msg ($cl, $self->{srv_prefix}, "001", 
                     "Welcome to NET::IRCServer! " 
                     . $self->mk_clpref ($cl), $cl->{nickname});
    $cl->{registered} = 1;
  }

  if ($c eq "PASS") {
    $cl->{password} = $msg->{params}->[0];
    
  } elsif ($c eq "JOIN") {
    my @chnls = split /,/, $msg->{params}->[0];
    my @keys;
    @keys = split /,/, $msg->{params}->[1] if defined $msg->{params}->[1];

    $self->join_channel ($cl, $_, pop @keys) for @chnls;
    
  } elsif ($c eq "PART") {
    my @chnls = split /,/, $msg->{params}->[0];
    $self->part_channel ($cl, $_, $msg->{params}->[1]) for @chnls;

  } elsif ($c eq "NOTICE" or $c eq "PRIVMSG") {
    $self->generic_msg ($cl, $msg->{params}->[0], $c, $msg->{params}->[1]);
  }

}

=item part_channel ($client, $channel, $reason)
 
 It will remove the C<$client> from the C<$channel> and will send a PART to all members of that channel.
 The part C<$reason> may be undefined.

=cut
sub part_channel {
  my ($self, $client, $chan, $reas) = @_;

  $self->channel_brdcst ($self->mk_clpref ($client), $chan, "PART", $reas, $chan);
  $self->remove_channel ($client, $chan);
}

=item join_channel ($client, $channel, $key)

=cut
sub join_channel {
  my ($self, $client, $chan, $key) = @_;

  if ($chan eq "0") {
    # part all channels of $client
    $self->part_channel ($client, $_) for keys %{$client->{channels}};
    $self->remove_channel ($client, $_) for keys %{$client->{channels}};

  } else {
    $self->add_channel ($client, $chan);
    $self->channel_brdcst ($self->mk_clpref ($client), $chan, "JOIN", $chan);
  }
}

sub add_channel {
  my ($self, $client, $channel) = @_;
  $self->{channels}->{lc $channel}->{lc $client->{nickname}} = $client;
  $client->{channels}->{lc $channel} = 1;
}

sub remove_channel {
  my ($self, $client, $channel) = @_;
  delete $self->{channels}->{lc $channel}->{lc $client->{nickname}};
  delete $client->{channels}->{lc $channel};
}

sub channel_brdcst {
  my ($self, $prefix, $channel, $command, @rmsg) = @_;
  $self->channel_brdcst_exclude (undef, $prefix, $channel, $command, @rmsg);
}

sub channel_brdcst_exclude {
  my ($self, $excl_cl, $prefix, $channel, $command, @rmsg) = @_;

  for (values %{$self->{channels}->{lc $channel}}) {
    if (not (defined $excl_cl) or $excl_cl != $_) {
      $self->send_msg ($_, $prefix, uc $command, @rmsg);
    }
  }
}


sub generic_msg {
  my ($self, $client, $target, $msgcmd, $msg) = @_;

  my $pref = $self->mk_clpref ($client);

  if (exists $self->{channels}->{lc $target}) {
    $self->channel_brdcst_exclude ($client, $pref, $target, uc ($msgcmd), $msg, $target);
  } else {
    $self->send_msg ($self->{reg_nicks}->{lc $target}, $pref, uc ($msgcmd), $msg, $target);
  }
}

sub check_nick_exists {
  my ($self, $nick) = @_;
  return 0;
}

sub change_nick {
  my ($self, $nick, $client) = @_;

  # check wether the nick to change to is already in use
  if (exists $self->{reg_nicks}->{lc $nick}) {
    $self->send_msg ($client, $self->{srv_prefix}, 433, "Nickname is already in use", $nick);
    return;
  }

  my %ppltotell; # hash-list of people to send a nick-update

  if (defined $client->{nickname}) {

    # update channels the client is on
    for my $c (keys %{$client->{channels}}) {

      # search the people to tell this nick changed
      for (values %{$self->{channels}->{lc $c}}) {
        $ppltotell{$_->{nickname}} = $_;
      }

      # change the nickname in the channel lists
      delete $self->{channels}->{lc $c}->{$client->{nickname}};
      $self->{channels}->{lc $c}->{$nick} = $client;
    }
  }

  if ($client->{registered}) { # only tell if this client is registered 

    # send us and others that the nick changed
    $ppltotell{$client->{nickname}} = $client;
    my $oldprfx = $self->mk_clpref ($client);
    $self->send_msg ($_, $oldprfx, "NICK", undef, $nick) for values %ppltotell;
  }

  # now update the client data
  delete $self->{reg_nicks}->{lc $client->{nickname}};
  $client->{nickname} = $nick;
  $self->{reg_nicks}->{$nick} = $client; 

  return 1;
}

our $cmd;
our $pref;
our $t;
our @a;

sub parse_irc_msg {
  my ($self, $msg) = @_;

  $cmd = "";
  $pref = "";
  $t = "";
  @a = ();

  my $p = $msg =~ 
          m/^( : ([^ ]+)(?{$pref = $^N}) [ ] )?   # the prefix
          
             ([A-Za-z]+|\d{3})(?{$cmd = $^N})     # the command

             ( 
                # now either 14 params and a trailing with optional ':'
                 (?{@a = ()}) (
                                ( [ ] ([^ :\r\n\0][^ \r\n\0]*)(?{push @a, $^N}) ){14} # params

                                ( [ ]:? ([^\r\n\0]*) (?{$t = $^N}) )?                  # trailing
                              )

               | # OR: 0 to 13 params and trailing with required ':'

                 (?{@a = ()}) (
                                ( [ ] ([^ :\r\n\0][^ \r\n\0]*)(?{push @a, $^N}) ){0,13} # 0 to 13 params

                                ( [ ]: ([^\r\n\0]*)(?{$t = $^N}) )?                     # trailing
                              )

             )
          $/x;

  my $m = { prefix => $pref, command => $cmd, params => \@a, trailing => $t };

  push @{$m->{params}}, $m->{trailing} if defined $m->{trailing};
  return $p ? $m : undef;
}

=back

=cut

1;