From c7f299eb798f9388d11a26ff77f9117cd6454df3 Mon Sep 17 00:00:00 2001
From: Sergiotarxz <sergiotarxz@posteo.net>
Date: Wed, 12 Jul 2023 03:27:33 +0200
Subject: [PATCH] Unit tests to check the races for sanity.

---
 lib/LasTres/Controller/Race.pm |   2 +-
 lib/LasTres/Planets.pm         |   1 -
 lib/LasTres/Races.pm           | 120 +++++++++++++++++----------------
 t/00-map-check.t               |   2 +-
 t/01-races.t                   | 114 +++++++++++++++++++++++++++++++
 5 files changed, 177 insertions(+), 62 deletions(-)
 create mode 100644 t/01-races.t

diff --git a/lib/LasTres/Controller/Race.pm b/lib/LasTres/Controller/Race.pm
index 483c657..bb62e93 100644
--- a/lib/LasTres/Controller/Race.pm
+++ b/lib/LasTres/Controller/Race.pm
@@ -13,7 +13,7 @@ sub playable($self) {
     my $races = LasTres::Races->new;
     my $hash;
     eval {
-        $hash = $races->hash_all_playable;
+        $hash = $races->hash_serialized_playable;
     };
     if ($@) {
         say STDERR $@;
diff --git a/lib/LasTres/Planets.pm b/lib/LasTres/Planets.pm
index 3bc93d0..ecb61c8 100644
--- a/lib/LasTres/Planets.pm
+++ b/lib/LasTres/Planets.pm
@@ -25,7 +25,6 @@ has hash => (
 sub _build_hash($self) {
     my @planets = $self->plugins();
     my %hash;
-    say @planets;
     for my $planet (@planets) {
         my $identifier = $planet->identifier;
         if (exists $hash{$planet->identifier}) {
diff --git a/lib/LasTres/Races.pm b/lib/LasTres/Races.pm
index cd3e6da..b9466ad 100644
--- a/lib/LasTres/Races.pm
+++ b/lib/LasTres/Races.pm
@@ -6,6 +6,7 @@ use strict;
 use warnings;
 
 use feature 'signatures';
+use Scalar::Util qw/blessed/;
 
 use Module::Pluggable search_path => ['LasTres::Race'],
     instantiate => 'new',
@@ -15,69 +16,70 @@ use Module::Pluggable search_path => ['LasTres::Race'],
 
 use Moo;
 
-has hash => (
-    is => 'lazy',
-);
-
-has hash_playable => (
-    is => 'lazy',
-);
-
-has hash_all => (
-    is => 'lazy',
-);
-
-has hash_all_playable => (
-    is => 'lazy',
-);
-
-sub _build_hash_all($self) {
-    my $hash = {};
-    my @races = $self->plugins();
-    for my $race (@races) {
-        $hash->{$race->identifier} = $race;
-    }
-    return { map { $_ => $self->hash->{$_}->hash } (keys %{$hash}) };
-}
-
-sub _build_hash_all_playable($self) {
-    my $hash = {};
-    my @races = $self->plugins();
-    for my $race (@races) {
-        $hash->{$race->identifier} = $race;
-    }
-    for my $race_key (keys %$hash) {
-        my $race = $hash->{$race_key}; 
-        if (!$race->is_playable) {
-            delete $hash->{$race_key};
+{
+    my @races;
+    sub _races_as_array($self) {
+        if (!scalar @races) {
+            @races = $self->plugins;
         }
-        $hash->{$race_key} = $race->hash;
+        return [@races];
     }
-    return $hash;
 }
 
-sub _build_hash($self) {
-    my $hash = {};
-    my @races = $self->plugins();
-    for my $race (@races) {
-        $hash->{$race->identifier} = $race;
-    }
-    return $hash;
-}
-
-sub _build_hash_playable($self) {
-    my $hash = {};
-    my @races = $self->plugins();
-    for my $race (@races) {
-        $hash->{$race->identifier} = $race;
-    }
-    for my $identifier_race (keys %$hash) {
-        my $race = $hash->{$identifier_race};
-        if (!$race->is_playable) {
-            delete $hash->{$identifier_race};
+{
+    my %hash;
+    sub hash($self) {
+        if (!scalar %hash) {
+            my @races = @{$self->_races_as_array};
+            for my $race (@races) {
+                if (exists $hash{$race->identifier}) {
+                    die blessed($race) . ' has a non unique identifier across races.';
+                }
+                $hash{$race->identifier} = $race;
+            }
         }
+        return {%hash};
+    }
+}
+
+{
+    my %hash_playable;
+    sub hash_playable($self) {
+        if (!scalar %hash_playable) {
+            %hash_playable = %{$self->hash};
+            for my $identifier (keys %hash_playable) {
+                my $race = $hash_playable{$identifier};
+                if (!$race->is_playable) {
+                    delete $hash_playable{$identifier};
+                }
+            }
+        }
+        return {%hash_playable};
+    }
+}
+
+{
+    my %hash_serialized;
+    sub hash_serialized($self) {
+        if (!scalar %hash_serialized) {
+            my %hash = %{$self->hash};
+            my @races = map { $hash{$_} } keys %hash;
+            %hash_serialized = map { $_->identifier => $_->hash } @races;
+        }
+        return {%hash_serialized};
+    }
+}
+
+{
+    my %hash_serialized_playable;
+    sub hash_serialized_playable($self) {
+        if (!scalar %hash_serialized_playable) {
+            my %hash = %{$self->hash_playable};
+            my @races = map { $hash{$_} } keys %hash;
+            %hash_serialized_playable = map { $_->identifier => $_->hash } @races;
+        }
+        return {%hash_serialized_playable};
     }
-    return $hash;
 }
 
 sub get($self, $race_identifier) {
@@ -87,10 +89,10 @@ sub get($self, $race_identifier) {
 sub get_playable($self, $race_identifier) {
     my $race = $self->hash->{$race_identifier};
     if (!defined $race) {
-        return undef;
+        return;
     }
     if (!$race->is_playable) {
-        return undef;
+        return;
     }
     return $race;
 }
diff --git a/t/00-map-check.t b/t/00-map-check.t
index 525d637..80bcb83 100644
--- a/t/00-map-check.t
+++ b/t/00-map-check.t
@@ -8,7 +8,7 @@ use feature 'signatures';
 
 use Scalar::Util qw/blessed/;
 
-use Test::Most tests => 11, qw/bail/;
+use Test::Most qw/no_plan bail/;
 
 {
     require LasTres::Planets;
diff --git a/t/01-races.t b/t/01-races.t
new file mode 100644
index 0000000..4ba922b
--- /dev/null
+++ b/t/01-races.t
@@ -0,0 +1,114 @@
+#!/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;
+}