115 lines
3.0 KiB
Perl
115 lines
3.0 KiB
Perl
#!/usr/bin/env perl
|
|
|
|
use v5.36.0;
|
|
use strict;
|
|
use warnings;
|
|
|
|
use feature 'signatures';
|
|
|
|
use Scalar::Util qw/blessed/;
|
|
|
|
use Test::Most qw/bail no_plan/;
|
|
|
|
{
|
|
use_ok 'LasTres::Races';
|
|
}
|
|
|
|
{
|
|
my $races = LasTres::Races->new;
|
|
use Data::Dumper;
|
|
my $hash = $races->hash;
|
|
my %old_hash = %$hash;
|
|
my $hash_playable = $races->hash_playable;
|
|
for my $identifier ( keys %$hash ) {
|
|
my $race = $hash->{$identifier};
|
|
test_race($race);
|
|
}
|
|
isnt $hash, $hash_playable, 'Hash and hash_playable are not equal.';
|
|
is_deeply $hash, {%old_hash}, 'The races hash is not changed by hash_playable.';
|
|
}
|
|
|
|
sub test_race ($race) {
|
|
ok $race->does('LasTres::Race'),
|
|
( blessed $race) . ' implements LasTres::Race.';
|
|
ok spawn_valid($race), ( blessed $race) . ' has a valid spawn attribute.';
|
|
ok identifier_valid($race),
|
|
( blessed $race) . ' has a valid identifier attribute.';
|
|
ok name_valid($race), ( blessed $race) . ' has a valid name attribute.';
|
|
ok name_selection_valid($race),
|
|
( blessed $race) . ' has a valid name_selection attribute.';
|
|
ok description_valid($race),
|
|
( blessed $race) . ' has a valid description attribute.';
|
|
}
|
|
|
|
sub experience_drop_base_valid ($race) {
|
|
my $is_defined = defined $race->experience_drop_base;
|
|
return 0 if ( !$is_defined );
|
|
|
|
# Negative or 0 not allowed, undefined behavior.
|
|
return 0 if $race->experience_drop_base < 1;
|
|
return 1;
|
|
}
|
|
|
|
sub description_valid ($race) {
|
|
return 0 if !defined $race->description;
|
|
|
|
# Description mandatory to be non empty
|
|
# because we want to use this in-game.
|
|
return 0 if length $race->description < 1;
|
|
return 1;
|
|
}
|
|
|
|
sub name_selection_valid ($race) {
|
|
my $is_defined = defined $race->name_selection;
|
|
return 0 if !$is_defined;
|
|
|
|
# For non players we do not care
|
|
# about empty strings.
|
|
return 0 if $race->is_playable && length $race->name_selection < 1;
|
|
return 1;
|
|
}
|
|
|
|
sub name_valid ($race) {
|
|
if ( !defined $race->name ) {
|
|
return 0;
|
|
}
|
|
|
|
# This is not a good is a string check, but I think
|
|
# most bugs with not being a string will be of this
|
|
# kind, not involving references.
|
|
return 1 if length $race->name > 0;
|
|
return 0;
|
|
}
|
|
|
|
sub identifier_valid ($race) {
|
|
return 0 if !defined $race->identifier;
|
|
|
|
# Not taking in account posible reference identifier
|
|
# would be overkill
|
|
return 0 if length $race->identifier < 1;
|
|
return 1;
|
|
}
|
|
|
|
sub spawn_valid ($race) {
|
|
my $is_playable = $race->is_playable;
|
|
my $spawn = $race->spawn;
|
|
if ( !$is_playable ) {
|
|
|
|
# We do not need to check further since
|
|
# we do not care about this attribute
|
|
# for unplayable races.
|
|
return 1;
|
|
}
|
|
if ( !defined $spawn ) {
|
|
|
|
# This is not allowed for playable races;
|
|
say STDERR 'Playable races must have an spawn.';
|
|
return 0;
|
|
}
|
|
if ( !( blessed $spawn) eq 'LasTres::Location' ) {
|
|
say STDERR 'Spawn must be a LasTres::Location object.';
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|