File Coverage

blib/lib/Games/Lacuna/Client/Module.pm

Criterion	Covered	Total	%
statement	21	69	30.4
branch	0	14	0.0
condition	0	15	0.0
subroutine	7	17	41.1
pod	0	6	0.0
total	28	121	23.1

package Games::Lacuna::Client::Module;
{
  $Games::Lacuna::Client::Module::VERSION = '0.003';
}
use 5.0080000;
use strict;
use warnings;
use Carp 'croak';

use Class::XSAccessor {
  getters => [qw(client uri)],
};

require Games::Lacuna::Client;

sub api_methods_without_session { croak("unimplemented"); }
sub api_methods_with_session { croak("unimplemented"); }

sub module_prefix {
  my $self = shift;
  my $class = ref($self)||$self;
  $class =~ /::(\w+)+$/ or croak("unimplemented");
  return lc($1);
}

sub session_id {
  my $self = shift;
  return $self->client->assert_session();
}

sub new {
  my $class = shift;
  my %opt = @_;
  my $client = $opt{client} || croak("Need Games::Lacuna::Client");

  my $self = bless {
    %opt,
  } => $class;
  $self->{uri} = $self->client->uri . '/' . $self->module_prefix;

  return $self;
}

sub init {
  my $class = shift;

  $class->_generate_api_methods($class->api_methods);
}

sub _generate_api_methods {
  my $class = shift;
  my $method_specs = shift || croak("Missing method specs");

  foreach my $method_name (keys %$method_specs) {
    my $target = $class->_find_target_name($method_name);
    my $spec = $method_specs->{$method_name};
    $class->_generate_method_per_spec($target, $method_name, $spec);
  }
}

sub _generate_method_per_spec {
  my $class       = shift;
  my $target      = shift;
  my $method_name = shift;
  my $spec        = shift;

  my $default_args  = $spec->{default_args};

  my $sub = sub {
    my $self = shift;
    my $client = $self->client;

    # prepend the default parameters to the arguments
    my $params = [
      (map $self->$_(), @$default_args),
      @_
    ];

    if ($client->debug) {
      print STDERR "DEBUG: " . __PACKAGE__ . " request " . Data::Dumper::Dumper([$self->uri, $method_name, $params]);
    }
    my $ret = $client->rpc->call($self->uri, $method_name, $params);
    if ($client->debug) {
      print STDERR "DEBUG: " . __PACKAGE__ . " result " . Data::Dumper::Dumper($ret);
    }

    if (ref $ret eq 'HASH' and exists $ret->{result} and ref $ret->{result} eq 'HASH') {
        $self->client->{rpc_count} =
            $ret->{result}{status} ? $ret->{result}{status}{empire}{rpc_count} :
            $ret->{result}{empire} ? $ret->{result}{empire}{rpc_count} :
            $self->client->{rpc_count};
    }

    return $ret->{result};
  };

  no strict 'refs';
  *{"$target"} = $sub;
}

sub _find_target_name {
  my $class = shift;
  my $method_name = shift;
  no strict 'refs';
  my $target = "${class}::$method_name";
  if (defined &{"$target"}) {
    $target = "${class}::_$method_name";
  }
  return $target;
}

1;
__END__

=head1 NAME

Games::Lacuna::Client::Empire - The empire module

=head1 SYNOPSIS

  use Games::Lacuna::Client;

=head1 DESCRIPTION

=head1 AUTHOR

Steffen Mueller, E<lt>[e-mail]<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2010 by Steffen Mueller

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.

=cut