view release on metacpan or  search on metacpan

lib/AnyEvent/IRC/Server.pm  view on Meta::CPAN

package AnyEvent::IRC::Server;

use strict;
use warnings;
our $VERSION = '0.03';
use base qw/Object::Event/;
use AnyEvent::Handle;
use AnyEvent::Socket;
use AnyEvent::IRC::Util qw/parse_irc_msg/;
use Sys::Hostname;
use POSIX;
use Scalar::Util qw/refaddr/;

use Class::Accessor::Lite (
    rw => [
        qw(host port handles servername channels topics spoofed_nick prepared_cb nick2handle)
    ],
);

my $CRLF = "\015\012";

BEGIN {
    no strict 'refs';
    while (my ($code, $name) = each %AnyEvent::IRC::Util::RFC_NUMCODE_MAP) {
        *{"${name}"} = sub () { $code };
    }
};

sub debugf {
    return unless $ENV{AEIS_DEBUG};
    require Data::Dumper;
    require Term::ANSIColor;
    local $Data::Dumper::Terse=1;
    local $Data::Dumper::Indent=0;
    my $fmt = shift;
    my $s = sprintf $fmt, (map {
        ref($_) ? (
            Data::Dumper::Dumper($_)
        ) : (defined($_) ? $_ : '<<UNDEF>>')
    } @_);
    my ($package, $filename, $line) = caller(0);
    $s .= " at $filename line $line\n";
    print Term::ANSIColor::colored(["cyan"], $s);
}

sub new {
    my $class = shift;
    my $self = $class->SUPER::new(
        handles      => {}, # refaddr($handle) => $handle
        channels     => {},
        topics       => {},
        spoofed_nick => {},
        nick2handle  => {}, # $nick => $hanldle,
        welcome      => 'Welcome to the my IRC server',
        servername   => hostname(),
        network      => 'AnyEventIRCServer',
        ctime        => POSIX::strftime( '%Y-%m-%d %H:%M:%S', localtime() ),
        channel_chars => '#&',
        prepared_cb  => sub {
            my ($self, $host, $port) = @_;
            print "$class is ready on : $host:$port\n";
        },
        @_,
    );

    
    my $say = sub {
        my ($handle, $cmd, @args) = @_;
        my $msg = mk_msg_ex($self->host, $cmd, $handle->{nick}, @args);
        debugf("Sending '%s'", $msg);
        $msg .= $CRLF;
        $handle->push_write($msg)
    };
    my $need_more_params = sub {
        my ($handle, $cmd) = @_;
        $say->($handle, ERR_NEEDMOREPARAMS, $cmd, 'Not enough parameters');
    };
    $self->reg_cb(
        nick => sub {
            my ($self, $msg, $handle) = @_;
            my ($nick) = @{$msg->{params}};
            unless (defined $nick) {
                return $need_more_params->($handle, 'NICK');
            }
            if ($self->nick2handle->{$nick}) {
                return $say->($handle, ERR_NICKNAMEINUSE, $nick, 'Nickname already in use');
            }
            debugf("Set nick: %s", $nick);
            $handle->{nick} = $nick;
            $self->nick2handle->{$nick} = $handle;
            # TODO: broadcast to each user
        },
        user => sub {
            my ($self, $msg, $handle) = @_;
            my ($user, $host, $server, $realname) = @{$msg->{params}};
            # TODO: Note that hostname and servername are normally ignored by the IRC server when the USER command comes from a directly connected client (for security reasons)
            $handle->{user} = $user;
            $handle->{hostname} = $host;