=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, [$command])

  The code-ref in the C<$sub> will be called everythime the server wants to send data to a client.

  If the C<$command> argument is given, the callback will only be called for irc-commands that match
  C<$command>. If the callback returns a true value when it's matched to a C<$command> the alternative callback
  (given without the C<$command>) won't be called.

  The callback will be called with following arguments: 
  
  $sub->($client, $data, $prefix, $command, $trailing, @params)

  $client   - the client datastructure you give C<parse_irc_stream ()>
  $data     - the raw data to send out, for example on a socket
  $prefix   - irc message prefix (may be undefined)
  $command  - irc command
  $trailing - the trailing irc parameter 
  @params   - the other params or the irc message

=cut
sub set_send_cb {
  my ($self, $cb, $cmd) = @_;

  if (defined $cmd) {
    $self->{send_cb_cmd}->{uc $cmd} = $cb;

  } else {
    $self->{send_cb} = $cb;
  }
}

=item set_cmd_cb ($cmd, $cb)

  Sets the command callback for the irc-command C<$cmd>.
  The callback is executed B<before> the command is evaluated
  by the server. If you want to prevent evaluation by the server
  later, you have to return a true value. Otherwise the server
  will evaluate the command and sends responses.

  There is are following special events/commands you can register
  a callback for, set C<$cmd> to:

  '*'    - to receive all commands
  '!'    - client successfully registered (after he send 
           PASS, NICK and USER and all commands were successful,
           NOTE: the returnvalue of this callback will be ignored)
  
  Arguments of the callback are like:

  $cb->($client, $ircmsg);

  $client  - the client datastructure for this command
  $ircmsg  - the irc-message hash containing:
  { 
    prefix => <irc-prefix>, 
    command => <irc-command>, 
    params => <irc-params including trailing>, 
    trailing => <the trailing parameter, also included in params>
  }

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

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

=item send_srv_msg ($client, @msg)

  Sends a irc-message to C<$client> with the server-prefix.
  @msg should look like: (<command>, <trailing>, <param-1>, ..., <param-n>)

=cut
sub send_srv_msg {
  my ($self, $client, @msg) = @_;
  $self->send_msg ($client, $self->{srv_prefix}, @msg);
}

=item send_msg ($client, @msg)

  Sends a irc-message to C<$client>.
  @msg should look like: (<prefix>, <command>, <trailing>, <param-1>, ..., <param-n>)

=cut
sub send_msg {
  my ($self, $client, @msg) = @_;
  my $r;

  $r = $self->{send_cb_cmd}->{uc $msg[1]}->($client, $self->mk_msg (@msg), @msg)
         if defined $self->{send_cb_cmd}->{uc $msg[1]};
         
  $self->{send_cb}->($client, $self->mk_msg (@msg), @msg)
    if defined $self->{send_cb} and not $r;
}


=item send_nameslist ($client, $channel)

  This sends the names-list of C<$channel> to the C<$client>.

=cut
sub send_nameslist {
  my ($self, $client, $channel) = @_;

  # TODO: Modes for users! Look here too:
  my @names = map { $_->{nickname} } values %{$self->{channels}->{lc $channel}};

  # TODO: Look for channel modes!
   
  my $i = 0;
  my @part;
  
  while (@names) {
    $i++;
    push @part, shift @names;
    
    if ($i % 10 == 0) {
      $self->send_srv_msg ($client, "353", join (' ', @part), $client->{nickname}, "=", $channel);
      @part = ();
    }
  }

  if (@part) {
    $self->send_srv_msg ($client, "353", join (' ', @part), $client->{nickname}, "=", $channel);
  }

  $self->send_srv_msg ($client, "366", "End of NAMES list", $client->{nickname}, $channel);
}

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};
}

=item feed_irc_data ($client, $data)

  Feeds raw IRC C<$data> for processing. When enough data for a command was
  feeded the command is handled and the callbacks set with C<set_cmd_cb> and C<set_post_cmd_cb>
  will be called. When the server wants to send a response he calls the callback set with C<set_send_cb>.

  The C<$client> data structure has to contain the C<hostname>-key, so the server can generate the irc
  message prefix for that client in his replys.

  In the callbacks the C<$client> data structure will be filled with followin keys:

  $client = {
    registered => <a flag (may be undef) whether the client finished the 
                   registration process and has a valid nickname and username>,
    nickname   => <the nickname the client currently has>,
    username   => <the username the client send when he logged in>,
    password   => <the password the client send when logged in>,
    hostname   => <this is what you have to provide>,
    channels   => { <channel-name> => 1, <channel2-name> => 1, ..., <channeln-name> }
                  (a hash of channel names the client is currently joined )
  };

=cut
sub feed_irc_data {
  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 = uc $msg->{command};

  my $r;
  $r ||= $self->{cmd_cbs}->{$c}->($cl, $msg) 
           if defined $self->{cmd_cbs}->{$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;

    $self->{cmd_cbs}->{"!"}->($cl, $msg) 
      if defined $self->{cmd_cbs}->{"!"};
  }

  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]);
    
  } elsif ($c eq "QUIT") {
    $self->quit ($cl, $msg->{params}->[0]);

  } elsif ($c eq "NAMES") {

    if (defined $msg->{params}->[1]) {
      $self->send_srv_msg ($cl,"402", "No such server", $msg->{params}->[1]);

    } elsif (defined $msg->{params}->[0]) {
      my @chans = split /,/, $msg->{params}->[0];
      $self->send_nameslist ($cl, $_) for @chans;

    } else {
      $self->send_nameslist ($cl, $_) for keys %{$self->{channels}};
    }
    
  } elsif ($c eq "PING") {
  
    if (defined $msg->{params}->[1]) {
      $self->send_srv_msg ($cl,"402", "No such server", $msg->{params}->[1]);
    } else {
      $self->send_srv_msg ($cl, "PONG", $msg->{params}->[0]);
    }
    
  } else {
    $self->send_srv_msg ($cl, "421", "Unknown command", $c)
      if $c ne "USER" and $c ne "NICK"; # handled above
  }

  $self->{post_cmd_cbs}->{$c}->($cl, $msg)  if defined $self->{post_cmd_cbs}->{$c};
  $self->{post_cmd_cbs}->{"*"}->($cl, $msg) if defined $self->{post_cmd_cbs}->{"*"};
}

=item quit ($client, $quitmsg)
 
  It will remove the C<$client> from all lists in the server, and broadcasts the
  C<$quitmsg> to all users on the channels the C<$client> was.

=cut
sub quit {
  my ($self, $client, $quitmsg) = @_;

  $self->channel_brdcst (
           $self->mk_clpref ($client), 
           $_, 
           "QUIT",
           $quitmsg) for keys %{$client->{channels}};

  $self->remove_channel ($client, $_) for keys %{$client->{channels}};
}

=item part_channel ($client, $channel, $reason)
 
 It will remove the C<$client> from the C<$channel> and will broadcast 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)

 It will add the C<$client> to the C<$channel> and will broadcast a JOIN to all members of that channel.

=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);
    $self->send_nameslist ($client, $chan);
  }
}

=item get_user_list ($channel)

  Get's the userlist of the $channel in the form:
  { nickname => client-structure, ... }

=cut
sub get_user_list {
  my ($self, $channel) = @_;
  return $self->{channels}->{lc $channel};
}

=item register_nick ($client, $nick)
  
  Registers the nickname C<$nick> in the server and sets it's
  client data structure to C<$client>.

=cut
sub register_nick {
  my ($self, $client, $nick) = @_;
  $self->{reg_nicks}->{lc $nick} = $client; 
}

=item get_nick ($nick)
 
  Returns the client datastructure for nickname C<$nick> or
  undef if there is no such nick;

=cut
sub get_nick {
  my ($self, $nick) = @_;
  $self->{reg_nicks}->{lc $nick};
}

=item unregister_nick ($nick)
  
  Unregisters the nickname C<$nick> in the server.

=cut
sub unregister_nick {
  my ($self, $client, $nick) = @_;
  delete $self->{reg_nicks}->{lc $client->{nickname}};
}

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};
}

=item channel_exists ($channel)

  Return true if there are clients who are joined to that channel.

=cut
sub channel_exists {
  my ($self, $channel) = @_;
  
  return undef 
    if not defined $self->{channels}->{lc $channel};
  return 
    (scalar (keys %{$self->{channels}->{lc $channel}}) != 0);
}

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->get_nick ($target), $pref, uc ($msgcmd), $msg, $target);
  }
}


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

  # check wether the nick to change to is already in use
  if ($self->get_nick ($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}->{lc $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
  $self->unregister_nick ($client->{nickname});

  $client->{nickname} = $nick;
  $self->register_nick ($client, $client->{nickname});

  return 1;
}

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

  my $cmd;
  my $pref;
  my $t;
  my @a;

  my $p = $msg =~ s/^(:([^ ]+)[ ])?([A-Za-z]+|\d{3})//;
  $pref = $2;
  $cmd = $3;

  my $i = 0;
  
  while ($msg =~ s/^[ ]([^ :\r\n\0][^ \r\n\0]*)//) {

    push @a, $1 if defined $1;
    if (++$i > 13) { last; }
  }
  
  if ($i == 14) {
  
    if ($msg =~ s/^[ ]:?([^\r\n\0]*)//) {
      $t = $1 if $1 ne "";
    }
    
  } else {
  
    if ($msg =~ s/^[ ]:([^\r\n\0]*)//) {
      $t = $1 if $1 ne "";
    }
  }
  
  push @a, $t if defined $t;

  my $m = { prefix => $pref, command => $cmd, params => \@a, trailing => $t };
  return $p ? $m : undef;
}

=back

=cut

1;