Something went wrong. Try again.
Perl game server for TLE Community
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503package Lacuna::TestSetup;
# Server-side implementation of the t/TestHelper.pm setup/teardown routines.## The Perl integration suite is slow mostly because every test does `use# TestHelper`, which does `use Lacuna`, which `Module::Find::useall`s the whole# app before the first assertion. The running plackup server already has all of# that compiled, so we expose the setup/teardown steps as functions here, called# over HTTP by Lacuna::Web::TestSetup, and let "naked" tests drive them with a# lightweight LWP-only client (t/TestClient.pm) instead.## These functions are deliberately near-verbatim ports of the matching# t/TestHelper.pm methods -- keep them in sync.
use strict;use warnings;use Lacuna;use DateTime;use Carp qw(confess);
use constant EMPIRE_NAME => 'TLE Test Empire';use constant EMPIRE_PASSWORD => '123qwe';use constant CLEAR_PATTERN => 'TLE Test%';
sub _empire_rs { Lacuna->db->resultset('Lacuna::DB::Result::Empire') }sub _building_rs { Lacuna->db->resultset('Lacuna::DB::Result::Building') }sub _ships_rs { Lacuna->db->resultset('Lacuna::DB::Result::Ships') }
# --- lookups --------------------------------------------------------------
sub empire_by_id { my ($id) = @_; confess [404, 'empire_id required'] unless $id; my $empire = _empire_rs()->find($id); confess [404, "empire $id not found"] unless $empire; return $empire;}
sub _planet_for { my ($args) = @_; if ($args->{planet_id}) { my $planet = Lacuna->db->resultset('Lacuna::DB::Result::Map::Body')->find($args->{planet_id}); confess [404, "planet $args->{planet_id} not found"] unless $planet; return $planet; } return empire_by_id($args->{empire_id})->home_planet;}
# --- empire lifecycle ---------------------------------------------------------
# Mirrors TestHelper::generate_test_empire. Deletes any same-named empire first,# inserts a fresh one, founds it (picks a home planet), starts a session.sub generate_empire { my (%args) = @_; my $name = $args{name} || EMPIRE_NAME; my $password = $args{password} || EMPIRE_PASSWORD;
my $empires = _empire_rs()->search({ name => $name }); while (my $e = $empires->next) { $e->delete }
my $empire = _empire_rs()->new({ name => $name, date_created => DateTime->now, status_message => 'Making Lacuna a better Expanse.', password => Lacuna::DB::Result::Empire->encrypt_password($password), })->insert; $empire->found;
my $session = $empire->start_session({ api_key => 'tester' });
return _empire_payload($empire, $session, $password);}
# Mirrors TestHelper::use_existing_test_empire. Reuse the persistent shared test# empire if it is already around; otherwise create it and build the big colony.sub use_existing_empire { my (%args) = @_; my $name = $args{name} || EMPIRE_NAME;
my ($empire) = _empire_rs()->search({ name => $name })->all; if (not $empire) { my $payload = generate_empire(name => $name); $empire = _empire_rs()->find($payload->{empire_id}); build_big_colony(empire_id => $empire->id); } my $session = $empire->start_session({ api_key => 'tester' }); return _empire_payload($empire, $session, $args{password} || EMPIRE_PASSWORD);}
sub _empire_payload { my ($empire, $session, $password) = @_; return { empire_id => $empire->id, empire_name => $empire->name, password => $password, session_id => $session->id, home_planet_id => $empire->home_planet_id, };}
# Mirrors TestHelper::clear_all_test_empires / cleanup.sub clear_empires { my (%args) = @_; my $name = $args{name} || CLEAR_PATTERN;
my $empires = _empire_rs()->search({ name => { like => $name } }); my $deleted = 0; while (my $empire = $empires->next) { $empire->essentia_game(0); $empire->essentia_free(0); $empire->essentia_paid(0); $empire->update;
my $planets = $empire->planets; while (my $planet = $planets->next) { my @buildings = grep { $_->class =~ /Permanent/ } @{$planet->building_cache}; $planet->delete_buildings(\@buildings); }
$empire->delete; $deleted++; } return { deleted => $deleted };}
# --- buildings --------------------------------------------------------------
# Mirrors TestHelper::find_empty_plot: walk the -5..5 grid for a free plot,# tracking the cursor in $cursor so repeated calls advance like TestHelper does.sub _next_free_plot { my ($home, $cursor) = @_; $cursor->{x} = -5 unless defined $cursor->{x}; $cursor->{y} = -5 unless defined $cursor->{y}; while (1) { my ($occupied) = grep { $_->x == $cursor->{x} && $_->y == $cursor->{y} } @{$home->building_cache}; last unless $occupied; $cursor->{x}++; if ($cursor->{x} == 6) { $cursor->{x} = -5; $cursor->{y}++; } } return ($cursor->{x}, $cursor->{y});}
# Mirrors TestHelper::build_building. Builds $class at $level (finished), on a# free plot (or the given x/y). Returns the new building's id/coords/level.sub build_building { my (%args) = @_; my $home = _planet_for(\%args); my $class = $args{class} or confess [400, 'class required']; my $level = $args{level} || 1;
my ($x, $y); if (defined $args{x} && defined $args{y}) { ($x, $y) = ($args{x}, $args{y}); } else { ($x, $y) = _next_free_plot($home, {}); }
my $building = _building_rs()->new({ x => $x, y => $y, class => $class, level => $level - 1, }); $home->build_building($building); $building->finish_upgrade;
return { building_id => $building->id, x => $x, y => $y, level => $building->level };}
# Mirrors `$tester->get_building($id)->finish_upgrade`. With building_id, finish# that one; with planet_id, finish every pending upgrade on the body.sub finish_building { my (%args) = @_; if ($args{building_id}) { my $building = _building_rs()->find($args{building_id}); confess [404, "building $args{building_id} not found"] unless $building; $building->finish_upgrade; return { ok => 1, finished => 1 }; } if ($args{planet_id}) { my $pending = _building_rs()->search({ body_id => $args{planet_id}, is_upgrading => 1 }); my $n = 0; while (my $b = $pending->next) { $b->finish_upgrade; $n++ } return { ok => 1, finished => $n }; } confess [400, 'building_id or planet_id required'];}
# Mirrors TestHelper::finish_ships.sub finish_ships { my (%args) = @_; my $shipyard_id = $args{shipyard_id} or confess [400, 'shipyard_id required']; _ships_rs()->search({ shipyard_id => $shipyard_id }) ->update({ date_available => DateTime->now, task => 'Docked' }); return { ok => 1 };}
# --- body resource poking --------------------------------------------------
# Mirrors the `$home->ore_capacity(...); $home->bauxite_stored(...); ...;# $home->needs_recalc(0); $home->update; $home->tick;` blocks that many tests# hand-write after building a lone University. Only whitelisted columns.my %RESOURCE_COLS = map { $_ => 1 } qw( ore_capacity energy_capacity food_capacity water_capacity ore_hour energy_hour water_hour algae_production_hour happiness needs_recalc bauxite_stored algae_stored energy_stored water_stored beryl_stored chromite_stored chalcopyrite_stored galena_stored goethite_stored gold_stored gypsum_stored halite_stored kerogen_stored magnetite_stored methane_stored monazite_stored rutile_stored sulfur_stored trona_stored uraninite_stored zircon_stored anthracite_stored bread_stored burger_stored cheese_stored chip_stored cider_stored corn_stored fungus_stored lapis_stored meal_stored milk_stored pancake_stored pie_stored potato_stored root_stored shake_stored soup_stored syrup_stored wheat_stored beetle_stored apple_stored bean_stored);
sub set_body_resources { my (%args) = @_; my $home = _planet_for(\%args); my $tick = delete $args{tick}; delete @args{qw(planet_id empire_id)};
for my $col (keys %args) { confess [400, "column '$col' is not settable via set_body_resources"] unless $RESOURCE_COLS{$col}; $home->$col($args{$col}); } $home->update; $home->tick if $tick; return { ok => 1 };}
# --- infrastructure -------------------------------------------------------
# Mirrors TestHelper::build_infrastructure.sub build_infrastructure { my (%args) = @_; my $empire = empire_by_id($args{empire_id}); my $home = $empire->home_planet; my $cursor = {};
my $build = sub { my ($type, $level) = @_; my ($x, $y) = _next_free_plot($home, $cursor); my $building = _building_rs()->new({ x => $x, y => $y, class => $type, level => $level - 1 }); $home->build_building($building); $building->finish_upgrade; };
for my $type ( 'Lacuna::DB::Result::Building::Food::Algae', 'Lacuna::DB::Result::Building::Energy::Hydrocarbon', 'Lacuna::DB::Result::Building::Water::Purification', 'Lacuna::DB::Result::Building::Water::Purification', 'Lacuna::DB::Result::Building::Water::Purification', 'Lacuna::DB::Result::Building::Ore::Mine', 'Lacuna::DB::Result::Building::Ore::Mine', 'Lacuna::DB::Result::Building::Ore::Mine', 'Lacuna::DB::Result::Building::Food::Algae', 'Lacuna::DB::Result::Building::Food::Algae', 'Lacuna::DB::Result::Building::Energy::Hydrocarbon', 'Lacuna::DB::Result::Building::Energy::Hydrocarbon', ) { $build->($type, 20); }
$home->empire->university_level(30); $home->empire->update;
for my $type ( 'Lacuna::DB::Result::Building::Energy::Reserve', 'Lacuna::DB::Result::Building::Food::Reserve', 'Lacuna::DB::Result::Building::Ore::Storage', 'Lacuna::DB::Result::Building::Water::Storage', ) { $build->($type, 20); }
if ($args{big_producer}) { $home->ore_hour(50000000); $home->water_hour(50000000); $home->energy_hour(50000000); $home->algae_production_hour(50000000); $home->ore_capacity(50000000); $home->energy_capacity(50000000); $home->food_capacity(50000000); $home->water_capacity(50000000); $home->bauxite_stored(50000000); $home->algae_stored(50000000); $home->energy_stored(50000000); $home->water_stored(50000000); $home->add_happiness(50000000); $home->monazite_stored(5000000); } else { $home->algae_stored(100_000); $home->bauxite_stored(100_000); $home->energy_stored(100_000); $home->water_stored(100_000); }
$home->tick; return { ok => 1 };}
# --- big colony ---------------------------------------------------------
# Mirrors TestHelper::build_big_colony. Wipes the planet, lays out a full# 30-level colony, seeds fleets (via the Shipyard RPC, in-process) and 1000# spies. Used by use_existing_empire's cold-start path.sub build_big_colony { my (%args) = @_; my $empire = empire_by_id($args{empire_id}); my $planet = $args{planet_id} ? Lacuna->db->resultset('Lacuna::DB::Result::Map::Body')->find($args{planet_id}) : $empire->home_planet; my $session = $empire->start_session({ api_key => 'tester' });
$planet->delete_buildings([ @{$planet->building_cache} ]); $planet->ships->delete_all; Lacuna->db->resultset('Spies')->search({ from_body_id => $planet->id })->delete_all;
my $layout = _big_colony_layout();
for my $class (keys %$layout) { for my $location (@{$layout->{$class}}) { my $building = _building_rs()->new({ x => $location->{x}, y => $location->{y}, class => "Lacuna::DB::Result::Building::$class", level => $location->{level} - 1, }); $planet->build_building($building); $building->finish_upgrade; } }
$planet->bauxite_stored(19_000_000_000); $planet->algae_stored(19_000_000_000); $planet->energy_stored(19_000_000_000); $planet->water_stored(19_000_000_000); $planet->needs_recalc(1); $planet->update; $planet->tick;
my ($shipyard) = grep { $_->class eq 'Lacuna::DB::Result::Building::Shipyard' } @{$planet->building_cache}; my $shipyard_rpc = Lacuna::RPC::Building::Shipyard->new;
my $ships = { excavator => 30, probe => 20, sweeper => 1300, fighter => 500, hulk => 250, detonator => 20, security_ministry_seeker => 20, smuggler_ship => 20, snark3 => 200, spy_pod => 20, spy_shuttle => 20, supply_pod4 => 10, }; for my $ship (keys %$ships) { my $result = $shipyard_rpc->build_ship($session->id, $shipyard->id, $ship); finish_ships(shipyard_id => $shipyard->id); next unless $ships->{$ship} > 1;
my $ship_id = $result->{ships_building}[0]{id}; my $example = _ships_rs()->find($ship_id); for (1 .. $ships->{$ship}) { _ships_rs()->create({ body_id => $example->body_id, shipyard_id => $example->shipyard_id, date_started => $example->date_started, date_available => $example->date_available, type => $example->type, task => $example->task, name => $example->name, speed => $example->speed, stealth => $example->stealth, combat => $example->combat, hold_size => $example->hold_size, payload => $example->payload, roundtrip => $example->roundtrip, direction => $example->direction, foreign_body_id => $example->foreign_body_id, foreign_star_id => $example->foreign_star_id, fleet_speed => $example->fleet_speed, }); } }
for (1 .. 1000) { my $spy = $empire->add_to_spies({ name => 'Null', from_body_id => $planet->id, on_body_id => $planet->id, task => 'Counter Espionage', started_assignment => '2012-01-01 12:00:00', available_on => '2012-01-01 12:00:00', offense => 2600, defense => 2600, date_created => DateTime->now(), offense_mission_count => 10 + int(rand(10)), defense_mission_count => 10 + int(rand(10)), offense_mission_successes => int(rand(3)), defense_mission_successes => int(rand(3)), times_captured => 0, times_turned => 0, seeds_planted => 0, spies_turned => 0, spies_captured => 0, spies_killed => 0, things_destroyed => int(rand(3)), things_stolen => int(rand(5)), intel_xp => 95 + int(rand(5)), mayhem_xp => 95 + int(rand(5)), politics_xp => 95 + int(rand(5)), theft_xp => 95 + int(rand(5)), level => 27 + int(rand(10)), }); $spy->name("ICY " . $spy->id); $spy->update; }
return { ok => 1 };}
sub _big_colony_layout { return { 'PlanetaryCommand' => [ { x => 0, y => 0, level => 30 } ], 'SpacePort' => [ (map { { x => $_->[0], y => $_->[1], level => 22 } } [-2,-2],[-1,-2],[0,-2],[1,-2],[2,-2], [-2,-1],[-1,-1],[0,-1],[1,-1],[2,-1], [-2,0],[-1,0],[1,0],[2,0], [-2,1],[-1,1],[0,1],[1,1],[2,1], [-2,2],[-1,2],[0,2],[1,2],[2,2], [4,-4],[4,-3],[4,-2],[4,-1],[4,0],[4,1],[4,2],[4,3],[4,4], [-4,-4],[-4,-3],[-4,-2],[-4,-1],[-4,0],[-4,1],[-4,2],[-4,3],[-4,4], [-3,-4],[-2,-4],[-1,-4],[0,-4],[1,-4],[2,-4],[3,-4], [-3,4],[-2,4],[-1,4],[0,4],[1,4],[2,4],[3,4], ), ], 'Permanent::Volcano' => [ { x => 1, y => -3, level => 30 } ], 'Permanent::InterDimensionalRift' => [ { x => 2, y => -3, level => 30 } ], 'Archaeology' => [ { x => 3, y => -3, level => 30 } ], 'Development' => [ { x => 0, y => -3, level => 30 } ], 'Permanent::GeoThermalVent' => [ { x => -1, y => -3, level => 30 } ], 'Espionage' => [ { x => -2, y => -3, level => 30 } ], 'Security' => [ { x => -3, y => -3, level => 30 } ], 'Intelligence' => [ { x => -3, y => -2, level => 30 } ], 'Embassy' => [ { x => -3, y => 0, level => 30 } ], 'Trade' => [ { x => 0, y => 3, level => 30 } ], 'Transporter' => [ { x => 3, y => 0, level => 30 } ], 'University' => [ { x => 3, y => -1, level => 30 } ], 'Observatory' => [ { x => 3, y => -2, level => 30 } ], 'TheftTraining' => [ { x => -3, y => 1, level => 30 } ], 'IntelTraining' => [ { x => -3, y => 2, level => 30 } ], 'MayhemTraining' => [ { x => -3, y => 3, level => 30 } ], 'PoliticsTraining' => [ { x => -2, y => 3, level => 30 } ], 'Permanent::NaturalSpring' => [ { x => -1, y => 3, level => 30 } ], 'Permanent::CrashedShipSite' => [ { x => 1, y => 3, level => 30 } ], 'CloakingLab' => [ { x => 2, y => 3, level => 30 } ], 'MunitionsLab' => [ { x => 3, y => 3, level => 30 } ], 'PilotTraining' => [ { x => 3, y => 2, level => 30 } ], 'Propulsion' => [ { x => 3, y => 1, level => 30 } ], 'Permanent::DentonBrambles' => [ { x => -5, y => 2, level => 30 } ], 'Permanent::AlgaePond' => [ { x => -5, y => 1, level => 30 } ], 'MercenariesGuild' => [ { x => -3, y => -1, level => 30 } ], 'Permanent::SpaceJunkPark' => [ { x => -5, y => -1, level => 30 } ], 'Permanent::PyramidJunkSculpture' => [ { x => -5, y => -2, level => 30 } ], 'Permanent::GratchsGauntlet' => [ { x => 5, y => 2, level => 30 } ], 'Permanent::Ravine' => [ { x => 5, y => 1, level => 30 } ], 'Permanent::JunkHengeSculpture' => [ { x => 5, y => -1, level => 30 } ], 'Permanent::MetalJunkArches' => [ { x => 5, y => -2, level => 30 } ], 'Permanent::GasGiantPlatform' => [ { x => 5, y => 5, level => 30 }, { x => 5, y => -5, level => 30 }, { x => -5, y => 5, level => 30 }, { x => -5, y => -5, level => 30 }, ], 'Shipyard' => [ { x => -2, y => 5, level => 30 }, { x => -1, y => 5, level => 30 }, { x => 1, y => 5, level => 30 }, { x => 2, y => 5, level => 30 }, { x => -2, y => -5, level => 30 },{ x => -1, y => -5, level => 30 }, { x => 1, y => -5, level => 30 }, { x => 2, y => -5, level => 30 }, ], 'SAW' => [ { x => -4, y => 5, level => 30 }, { x => 4, y => 5, level => 30 }, { x => -4, y => -5, level => 30 },{ x => 4, y => -5, level => 30 }, { x => -5, y => 4, level => 30 }, { x => 5, y => 4, level => 30 }, { x => -5, y => -4, level => 30 },{ x => 5, y => -4, level => 30 }, { x => 0, y => 5, level => 30 }, { x => 0, y => -5, level => 30 }, ], };}
1;