Something went wrong. Try again.
Perl game server for TLE Community
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221package TestClient;
# Lightweight counterpart to t/TestHelper.pm for "naked" tests -- those that only# need a test empire plus JSON-RPC HTTP calls. It talks to the dev-only /test# endpoints (lib/Lacuna/Web/TestSetup.pm) for all setup/teardown, so it can load# with just LWP + JSON and skip the multi-second `use Lacuna` compile that# TestHelper pays per test file.## Drop-in for the common TestHelper surface: ->new, ->generate_test_empire,# ->use_existing_test_empire, ->build_infrastructure, ->post, ->get_building,# ->session->id, ->empire->id, ->empire->home_planet->id, ->empire_name,# TestClient->clear_all_test_empires. Tests that reach deeper into Lacuna objects# are "bespoke" and should stay on TestHelper.
use strict;use warnings;use LWP::UserAgent;use JSON qw(to_json from_json);use Carp qw(croak);
sub new { my ($class, $args) = @_; $args ||= {}; my $url = $ENV{LACUNA_TEST_SERVER_URL} || 'http://localhost:5000/'; $url .= '/' unless $url =~ m{/$}; my $self = bless { server_url => $url, ua => LWP::UserAgent->new(timeout => 30), big_producer => $args->{big_producer} ? 1 : 0, empire_name => $args->{empire_name}, empire_id => undef, session_id => undef, home_planet_id => undef, password => undef, }, $class; return $self;}
# --- low-level HTTP -------------------------------------------------------
# JSON-RPC call -- identical wire format to TestHelper::post.sub post { my ($self, $url, $method, $params) = @_; my $content = { jsonrpc => '2.0', id => 1, method => $method, params => $params }; print "REQUEST: " . to_json($content) . "\n"; my $response = $self->{ua}->post( $self->{server_url} . $url, Content_Type => 'application/json', Content => to_json($content), Accept => 'application/json', ); print "RESPONSE: " . $response->content . "\n"; return from_json($response->content);}
# POST a JSON body to /test/<path>, return the decoded hash (croak on failure).sub _setup { my ($self, $path, $body) = @_; my $response = $self->{ua}->post( $self->{server_url} . "test/$path", Content_Type => 'application/json', Content => to_json($body || {}), Accept => 'application/json', ); unless ($response->is_success) { croak "POST /test/$path failed: " . $response->status_line . " -- " . $response->content; } return from_json($response->content);}
# --- empire lifecycle ---------------------------------------------------------
sub generate_test_empire { my ($self, %opts) = @_; my $out = $self->_setup('generate_empire', { name => $opts{name} || $self->{empire_name}, password => $opts{password}, }); $self->_absorb($out); return $self;}
sub use_existing_test_empire { my ($self, %opts) = @_; my $out = $self->_setup('use_existing_empire', { name => $opts{name} || $self->{empire_name}, password => $opts{password}, }); $self->_absorb($out); return $self;}
sub _absorb { my ($self, $out) = @_; $self->{empire_id} = $out->{empire_id}; $self->{empire_name} = $out->{empire_name}; $self->{session_id} = $out->{session_id}; $self->{home_planet_id} = $out->{home_planet_id}; $self->{password} = $out->{password};}
sub build_infrastructure { my ($self, %opts) = @_; $self->_setup('build_infrastructure', { empire_id => $self->{empire_id}, big_producer => (exists $opts{big_producer} ? $opts{big_producer} : $self->{big_producer}), }); return $self;}
sub build_big_colony { my ($self, %opts) = @_; $self->_setup('build_big_colony', { empire_id => $self->{empire_id}, planet_id => $opts{planet_id}, }); return $self;}
# --- buildings / resources ------------------------------------------------
# Returns a small stub so `$tester->build_building(...)->id` /# `->finish_upgrade` keep working like TestHelper's building object.sub build_building { my ($self, $class, $level) = @_; my $out = $self->_setup('build_building', { empire_id => $self->{empire_id}, class => $class, level => $level, }); return TestClient::Building->new($self, $out);}
# TestHelper::get_building returns a live Building; here we only support the one# thing naked tests do with it -- ->finish_upgrade (and ->id).sub get_building { my ($self, $building_id) = @_; return TestClient::Building->new($self, { building_id => $building_id });}
sub finish_building { my ($self, $building_id) = @_; return $self->_setup('finish_building', { building_id => $building_id });}
sub finish_ships { my ($self, $shipyard_id) = @_; return $self->_setup('finish_ships', { shipyard_id => $shipyard_id });}
# set_body_resources($planet_id, ore_capacity => ..., algae_stored => ..., tick => 1)sub set_body_resources { my ($self, $planet_id, %cols) = @_; return $self->_setup('set_body_resources', { planet_id => $planet_id, %cols });}
sub prime_captcha { my ($self, %opts) = @_; return $self->_setup('prime_captcha', { session_id => (exists $opts{session_id} ? $opts{session_id} : $self->{session_id}), ip => $opts{ip}, });}
# --- teardown -----------------------------------------------------------
# Callable as class or instance method (incl. from END {}).sub clear_all_test_empires { my ($invocant, $name) = @_; my $self = ref $invocant ? $invocant : TestClient->new; return $self->_setup('clear_empires', { name => $name });}sub cleanup { goto &clear_all_test_empires }
# --- accessors -----------------------------------------------------------
sub server_url { $_[0]->{server_url} }sub session_id { $_[0]->{session_id} }sub empire_id { $_[0]->{empire_id} }sub home_planet_id { $_[0]->{home_planet_id} }sub empire_name { $_[0]->{empire_name} // 'TLE Test Empire' }sub empire_password { $_[0]->{password} // '123qwe' }
# Back-compat object stubs so a header swap is usually the whole diff.sub session { TestClient::Session->new($_[0]) }sub empire { TestClient::Empire->new($_[0]) }
# ======================================================================
package TestClient::Building;sub new { my ($class, $client, $out) = @_; return bless { client => $client, %{ $out || {} } }, $class;}sub id { $_[0]->{building_id} }sub x { $_[0]->{x} }sub y { $_[0]->{y} }sub level { $_[0]->{level} }sub finish_upgrade { my ($self) = @_; $self->{client}->finish_building($self->{building_id}); return $self;}
package TestClient::Session;sub new { bless { client => $_[1] }, $_[0] }sub id { $_[0]->{client}->session_id }
package TestClient::Empire;sub new { bless { client => $_[1] }, $_[0] }sub id { $_[0]->{client}->empire_id }sub name { $_[0]->{client}->empire_name }sub home_planet_id { $_[0]->{client}->home_planet_id }sub home_planet { TestClient::Body->new($_[0]->{client}) }
package TestClient::Body;sub new { bless { client => $_[1] }, $_[0] }sub id { $_[0]->{client}->home_planet_id }
1;