Hoppy - Flash XMLSocket Server.

  use Hoppy;

  use MyService::Auth;
  use MyService::Chat;

  my $config = {
    alias => 'hoppy',
    port  => 12345,
    test  => 1,      # does not work POE::Filter::Line ( use it as telnet when debug phaze )
  };

  my $server = Hoppy->new(config => $config);

  $server->regist_service(
     auth => 'MyService::Auth',
     chat => 'MyService::Chat',
  );

  $server->start;

package Hoppy;
use strict;
use warnings;
use EV;
use POE;
use POE::Sugar::Args;
use POE::Filter::Line;
use POE::Component::Server::TCP;
use Hoppy::TCPHandler;
use UNIVERSAL::require;
use Carp;
use base qw(Hoppy::Base);

__PACKAGE__->mk_accessors($_) for qw(handler formatter service hook room);

our $VERSION = '0.01005';

sub new {
    my $class = shift;
    my $self  = $class->SUPER::new(@_);
    $self->_setup;
    return $self;
}

sub start {
    my $self = shift;
    if ( my $hook = $self->hook->{start} ) {
        $hook->work();
    }
    POE::Kernel->run;
}

sub stop {
    my $self = shift;
    if ( my $hook = $self->hook->{stop} ) {
        $hook->work();
    }
    POE::Kernel->stop;
}

sub dispatch {
    my $self       = shift;
    my $in_data    = shift;
    my $poe        = shift;
    my $session_id = $poe->session->ID;
    my $method     = $in_data->{method};
    if ( $method eq 'login' ) {
        my $args = { in_data => $in_data, poe => $poe };
        $self->service->{login}->work($args);
    }
    elsif ( $self->{not_authorized}->{$session_id} ) {
        my $message    = "not authorized. you have to login()";
        my $out_data   = { result => "", "error" => $message };
        my $serialized = $self->formatter->serialize($out_data);
        $self->handler->{Send}->do_handle( $poe, $serialized );
    }
    else {
        my $user = $self->room->fetch_user_from_session_id($session_id);
        return unless $user;
        my $user_id = $user->user_id;
        my $args = { user_id => $user_id, in_data => $in_data, poe => $poe };
        eval { $self->service->{$method}->work($args) };
    }
}

sub unicast {
    my $self       = shift;
    my $args       = shift;
    my $user_id    = $args->{user_id};
    my $message    = $args->{message};
    my $session_id = $args->{session_id};
    eval {
        if ( !$session_id and $user_id )
        {
            my $user = $self->room->fetch_user_from_user_id($user_id);
            $session_id = $user->session_id;
        }
        $poe_kernel->post( $session_id => "Send" => $message );
    };
}

sub multicast {
    my $self    = shift;
    my $args    = shift;
    my $sender  = $args->{sender};
    my $message = $args->{message};
    my $room_id = $args->{room_id};
    my $users   = $self->room->fetch_users_from_room_id($room_id);
    for my $user (@$users) {
        my $session_id = $user->session_id;
        if ( $sender and $session_id != $sender ) {
            $poe_kernel->post( $session_id => "Send" => $message );
        }
    }
}

sub broadcast {
    my $self    = shift;
    my $args    = shift;
    my $sender  = $args->{sender};
    my $message = $args->{message};
    for my $session_id ( keys %{ $self->{sessions} } ) {
        if ( $sender and $session_id != $sender ) {
            $poe_kernel->post( $session_id => "Send" => $message );
        }
    }
}

sub regist_service {
    my $self = shift;
    while (@_) {
        my $label = shift @_;
        my $class = shift @_;
        unless ( ref($class) ) {
            $class->require or die $@;
            my $obj = $class->new( context => $self );
            $self->service->{$label} = $obj;
        }
        else {
            $self->service->{$label} = $class;
        }
    }
}

sub regist_hook {
    my $self = shift;
    while (@_) {
        my $label = shift @_;
        my $class = shift @_;
        unless ( ref($class) ) {
            $class->require or die $@;
            my $obj = $class->new( context => $self );
            $self->hook->{$label} = $obj;
        }
        else {
            $self->hook->{$label} = $class;
        }
    }
}

sub _setup {
    my $self = shift;
    $self->_load_classes;
    my $filter = POE::Filter::Line->new( Literal => "\x00" );
    if ( $self->config->{test} and $self->config->{test} == 1 ) {
        $filter = undef;
    }
    elsif ( $self->config->{test} and $self->config->{test} == 2 ) {
        Hoppy::TestFilter->require or croak $@;
        $filter = Hoppy::TestFilter->new($self);
    }

    POE::Component::Server::TCP->new(
        Alias => $self->config->{alias} || 'xmlsocketd',
        Port  => $self->config->{port}  || 10000,
        ClientConnected    => sub { $self->_tcp_handle( Connected    => @_ ) },
        ClientInput        => sub { $self->_tcp_handle( Input        => @_ ) },
        ClientDisconnected => sub { $self->_tcp_handle( Disconnected => @_ ) },
        ClientError        => sub { $self->_tcp_handle( Error        => @_ ) },

        ClientFilter => $filter,
        InlineStates => {
            Send => sub {
                $self->_tcp_handle( Send => @_ );
            },
        },
    );
    POE::Kernel->sig( INT => sub { POE::Kernel->stop } );
}

sub _load_classes {
    my $self = shift;

    # tcp handler
    {
        $self->handler( {} );
        for (qw(Input Connected Disconnected Error Send)) {
            my $class = __PACKAGE__ . '::TCPHandler::' . $_;
            $self->handler->{$_} = $class->new( context => $self );
        }
    }

    # io formatter
    {
        my $class = $self->config->{Formatter}
          || __PACKAGE__ . '::Formatter::JSON';
        $class->require or croak $@;
        $self->formatter( $class->new( context => $self ) );
    }

    # default service
    {
        $self->service( {} );
        my @services = (
            { login  => __PACKAGE__ . '::Service::Login' },
            { logout => __PACKAGE__ . '::Service::Logout' },
        );
        if ( $self->config->{regist_services} ) {
            while ( my ( $key, $value ) =
                each %{ $self->config->{regist_services} } )
            {
                push @services, { $key => $value };
            }
        }
        for (@services) {
            my ( $label, $class ) = %$_;
            $class->require or croak $@;
            $self->service->{$label} = $class->new( context => $self );
        }
    }

    # default hook
    {
        $self->hook( {} );
        my @hooks = ();
        if ( $self->config->{regist_hooks} ) {
            while ( my ( $key, $value ) =
                each %{ $self->config->{regist_hooks} } )
            {
                push @hooks, { $key => $value };
            }
        }
        for (@hooks) {
            my ( $label, $class ) = %$_;
            $class->require or croak $@;
            $self->hook->{$label} = $class->new( context => $self );
        }
    }

    # room
    {
        my $class = $self->config->{Room}
          || __PACKAGE__ . '::Room::Memory';
        $class->require or croak $@;
        $self->room( $class->new( context => $self ) );
    }
}

sub _tcp_handle {
    my $self         = shift;
    my $handler_name = shift;
    my $poe          = POE::Sugar::Args->new(@_);
    $self->handler->{$handler_name}->do_handle($poe);
}

1;
__END__