From f88dbb7027052857e524319322b526fec36937be Mon Sep 17 00:00:00 2001 From: Dave Cross Date: Wed, 24 May 2023 16:32:08 +0100 Subject: [PATCH 1/2] Add abbr attribute --- Changes.md | 1 + lib/Genealogy/Relationship.pm | 52 +++++++++++++++++++++++++++++++++-- t/03-cousins.t | 29 ++++++++++++++----- 3 files changed, 72 insertions(+), 10 deletions(-) diff --git a/Changes.md b/Changes.md index 3b64ac7..cad6623 100644 --- a/Changes.md +++ b/Changes.md @@ -7,6 +7,7 @@ - Pod error - IDs no longer need to be numbers - Added `get_relationship_ancestors()` method +- Added `abbr` attribute ## [0.1.2] - 2023-05-23 diff --git a/lib/Genealogy/Relationship.pm b/lib/Genealogy/Relationship.pm index 39e3944..a0150c6 100644 --- a/lib/Genealogy/Relationship.pm +++ b/lib/Genealogy/Relationship.pm @@ -75,6 +75,18 @@ how to fix it as soon as possible. =back +=head2 Constructor + +The constructor for this class takes one optional attribute called `abbr`. +The default value for this attribute is 2. When set, strings of repeated +"great"s in a relationship description will collapsed to "$n x great". + +For example, if the description you have is "Great, great, great +grandfather", then that will be abbreviated to to "3 x great grandfather". + +The value for `abbr` is the maximum number of repetitions that will be left +untouched. You can turn abbreviations off by setting `abbr` to zero. + =head2 Caching Calculating relationship names isn't at all different. But there can be a lot @@ -89,7 +101,7 @@ consider putting a caching layer in front of C. package Genealogy::Relationship; use Moo; -use Types::Standard qw[Str HashRef]; +use Types::Standard qw[Int Str HashRef]; use List::Util qw[first]; use List::MoreUtils qw[firstidx]; use Lingua::EN::Numbers qw[num2en num2en_ordinal]; @@ -141,6 +153,12 @@ sub _build_relationship_table { }; } +has abbr => ( + is => 'ro', + isa => Int, + default => 3, +); + =head1 Methods The following methods are defined. @@ -207,12 +225,40 @@ sub get_relationship { my ($x, $y) = $self->get_relationship_coords($person1, $person2); + my $rel; + if (defined $self->relationship_table->{$person1->gender}[$x][$y]) { - return $self->relationship_table->{$person1->gender}[$x][$y]; + $rel = $self->relationship_table->{$person1->gender}[$x][$y]; } else { - return $self->relationship_table->{$person1->gender}[$x][$y] = + $rel = $self->relationship_table->{$person1->gender}[$x][$y] = ucfirst $self->make_rel($person1->gender, $x, $y); } + + $rel = $self->abbr_rel($rel) if $self->abbr; + + return $rel; +} + +=head2 abbr_rel + +Optionally abbreviate a relationship description. + +=cut + +sub abbr_rel { + my $self = shift; + my ($rel) = @_; + + return $rel unless $self->abbr; + + my @greats = $rel =~ /(great)/gi; + my $count = @greats; + + return $rel if $count < $self->abbr; + + $rel =~ s/(great,\s+)+/$count x /i; + + return $rel; } =head2 make_rel diff --git a/t/03-cousins.t b/t/03-cousins.t index 1a0d28f..9bddb93 100644 --- a/t/03-cousins.t +++ b/t/03-cousins.t @@ -22,12 +22,12 @@ my @expected = ( [ 'First cousin', 'Uncle' ], [ 'Second cousin', 'Great uncle' ], [ 'Third cousin', 'Great, great uncle' ], - [ 'Fourth cousin', 'Great, great, great uncle' ], - [ 'Fifth cousin', 'Great, great, great, great uncle' ], - [ 'Sixth cousin', 'Great, great, great, great, great uncle' ], - [ 'Seventh cousin', 'Great, great, great, great, great, great uncle' ], - [ 'Eighth cousin', 'Great, great, great, great, great, great, great uncle' ], - [ 'Ninth cousin', 'Great, great, great, great, great, great, great, great uncle' ], + [ 'Fourth cousin', '3 x great uncle' ], + [ 'Fifth cousin', '4 x great uncle' ], + [ 'Sixth cousin', '5 x great uncle' ], + [ 'Seventh cousin', '6 x great uncle' ], + [ 'Eighth cousin', '7 x great uncle' ], + [ 'Ninth cousin', '8 x great uncle' ], ); for my $g (1 .. 10) { @@ -73,4 +73,19 @@ is($rel->get_relationship($generations[9][0], $generations[9][1]), is($rel->get_relationship($generations[8][0], $generations[5][1]), 'Fourth cousin three times removed'); -done_testing; \ No newline at end of file +can_ok($rel, 'abbr'); + +# Test a higher number for abbr +$rel = Genealogy::Relationship->new(abbr => 4); +is($rel->get_relationship($generations[1][0], $generations[5][1]), 'Great, great, great uncle'); +is($rel->get_relationship($generations[1][0], $generations[6][1]), '4 x great uncle'); + +# Turn off abbr +$rel = Genealogy::Relationship->new(abbr => 0); +is($rel->get_relationship($generations[1][0], $generations[3][1]), 'Great uncle'); +is($rel->get_relationship($generations[1][0], $generations[4][1]), 'Great, great uncle'); +is($rel->get_relationship($generations[1][0], $generations[5][1]), 'Great, great, great uncle'); + + +done_testing; + From ae5e7fa35f9613b39dd55c8d77d82718f7f38c92 Mon Sep 17 00:00:00 2001 From: Dave Cross Date: Wed, 24 May 2023 16:43:13 +0100 Subject: [PATCH 2/2] Prep 0.2.0 for release --- Changes.md | 5 ++++- lib/Genealogy/Relationship.pm | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/Changes.md b/Changes.md index cad6623..0d92114 100644 --- a/Changes.md +++ b/Changes.md @@ -1,11 +1,14 @@ # Change Log -## [Unreleased] +## [0.2.0 - 2023-05-24] ### Fixed - Pod error - IDs no longer need to be numbers + +### Added + - Added `get_relationship_ancestors()` method - Added `abbr` attribute diff --git a/lib/Genealogy/Relationship.pm b/lib/Genealogy/Relationship.pm index a0150c6..2217527 100644 --- a/lib/Genealogy/Relationship.pm +++ b/lib/Genealogy/Relationship.pm @@ -106,7 +106,7 @@ use List::Util qw[first]; use List::MoreUtils qw[firstidx]; use Lingua::EN::Numbers qw[num2en num2en_ordinal]; -our $VERSION = '0.1.2'; +our $VERSION = '0.2.0'; has parent_field_name => ( is => 'ro',