File Coverage

blib/lib/Genealogy/AncestorChart.pm
Criterion Covered Total %
statement 61 67 91.0
branch 8 12 66.6
condition n/a
subroutine 14 15 93.3
pod 8 8 100.0
total 91 102 89.2


\n]; \n", @cells, "\n"; "} @{ $self->table_headers };
line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Genealogy::AncestorChart - create a table of genealogical ancestors.
4              
5             =head1 SYNOPSIS
6              
7             use Genealogy::AncestorChart;
8              
9             my @people = ($me, $dad, $mum, ...);
10              
11             my $chart = Genealogy::AncestorChart->new({
12             people => \@people,
13             });
14              
15             say $gac->chart;
16              
17             =head1 DESCRIPTION
18              
19             This module draws an HTML table which contains a representation of ancestors.
20             For the first three generations, the table will look like this:
21              
22             +-------------+-------------+----------------+
23             | Person | Parents | Grandparents |
24             +-------------+-------------+----------------+
25             | 1: Person | 2: Father | 4: Grandfather |
26             | | +----------------+
27             | | | 5: Grandmother |
28             | +-------------+----------------+
29             | | 3: Mother | 6: Grandfather |
30             | | +----------------+
31             | | | 7: Grandmother |
32             +-------------+-------------+----------------+
33              
34             The labels inside the table are generated from the array of people that is
35             passed into the constructor when the object is created.
36              
37             =head1 METHODS
38              
39             =head2 new(\%options)
40              
41             The constructor method. Builds a new instance of the class and returns that
42             object. Takes a hash reference containing various parameters.
43              
44             =over 4
45              
46             =item * people
47              
48             This is the only mandatory option.
49              
50             This should be a reference to a hash of objects. The key in the hash should
51             be an "Ahnentafel number" (see below) and the value should be an object will
52             represent one person to be displayed in the output. The text displayed
53             for each person is retrieved by calling a method on the relevant object.
54             The default method name is C, but this can be changed
55             using the C option, described below.
56              
57             These objects can be of any class - as long as they have a method of the
58             correct name that returns a text string that can be used in the table
59             output to identify the person in question.
60              
61             The keys in the hash should be "Ahnentafel numbers". This is a series
62             of positive integers that genealogists use to identify the ancestors of
63             an individual. The person of interest is given the number 1. Their
64             father and mother are 2 and 3, respectively. Their grandparents are
65             numbers 4 to 7 in the order father's father, father's mother, mother's
66             father and mother's mother. These numbers have the property that if you
67             know the number of a person in the hash, then you can get the number of
68             their father by doubling their number. Similarly, you can get the number
69             of their mother by doubling their number and adding one.
70              
71             Because of the nature of the table that is produced, the number of
72             people in your array should be one less than a power of two (i.e. 1, 3,
73             7, 15, 31, 63, etc.) For any any other number, a table will still be
74             produced, but it won't be guaranteed to be valid HTML.
75              
76             In the future, I might introduce a "strict" mode that only allows a valid
77             number of people in the array.
78              
79             =item * label_method
80              
81             This is the name of the method that should be called on the objects in the
82             "people" array. The default value is C.
83              
84             =item * headers
85              
86             An array reference containing the list of titles that are used for the first
87             few columns in the table. The default list is 'Person', 'Parents',
88             'Grandparents' and 'Great Grandparents'. You might want to override this if,
89             for example, you want the output in a different language.
90              
91             =item * extra_headers
92              
93             A string containing the basis for an extra headers that are required after
94             the fixed list stored in C. In English, we use the terms
95             'Great Great Grandparents', 'Great Great Great Grandparents' and so on. So
96             the default value for this string is 'Gt Grandparents'. This is prepended
97             with an incrementing string (which starts at 2) so we get the strings
98             '2 Gt Grandparents', '3 Gt Grandparents', and so on.
99              
100             You might want to override this if, for example, you want the output in a
101             different language.
102              
103             =back
104              
105             =cut
106              
107             package Genealogy::AncestorChart;
108              
109 2     2   58885 use strict;
  2         12  
  2         51  
110 2     2   11 use warnings;
  2         3  
  2         65  
111              
112             our $VERSION = '0.0.2';
113              
114 2     2   1654 use Moo;
  2         19577  
  2         9  
115 2     2   4192 use Types::Standard qw[ArrayRef HashRef Str Object];
  2         155233  
  2         26  
116              
117             has people => (
118             is => 'ro',
119             isa => HashRef[Object],
120             required => 1,
121             );
122              
123             =head2 num_people
124              
125             Returns the number of people in the list of people.
126              
127             =cut
128              
129             sub num_people {
130 5     5 1 6 return keys %{ $_[0]->people };
  5         28  
131             }
132              
133             has label_method => (
134             is => 'lazy',
135             isa => Str,
136             );
137              
138             sub _build_label_method {
139 1     1   23 return 'display_name',
140             }
141              
142             has headers => (
143             is => 'lazy',
144             isa => ArrayRef[Str],
145             );
146              
147             sub _build_headers {
148             return [
149 1     1   22 'Person', 'Parents', 'Grandparents',
150             'Great Grandparents',
151             ];
152             }
153              
154             has extra_header => (
155             is => 'lazy',
156             isa => Str,
157             );
158              
159             sub _build_extra_header {
160 0     0   0 return 'Gt Grandparents';
161             }
162              
163             =head2 num_rows
164              
165             Returns the number of rows that will be in the table. This is calculated
166             from the list of people.
167              
168             It is unlikely that you will need to call this method.
169              
170             =cut
171              
172             sub num_rows {
173 1     1 1 12 my $self = shift;
174              
175 1         1 return int ( keys( %{ $self->people } ) / 2 ) + 1;
  1         8  
176             }
177              
178             =head2 rows
179              
180             Returns the list of rows that will be used to create the table.
181              
182             It is unlikely that you will need to call this method.
183              
184             =cut
185              
186             sub rows {
187 2     2 1 4379 my $self = shift;
188              
189 2         6 my ($start, $end) = $self->row_range;
190              
191 2         5 return map { $self->row($_) } $start .. $end;
  8         16  
192             }
193              
194             =head2 row_range
195              
196             Returns a start and end point that is used in creating the rows of
197             the table.
198              
199             It is unlikely that you will need to call this method.
200              
201             =cut
202              
203             sub row_range {
204 2     2 1 3 my $self = shift;
205              
206 2         3 my $end = keys %{ $self->people };
  2         5  
207 2         10 my $start = int(($end / 2) + 1);
208              
209 2         5 return ($start, $end);
210             }
211              
212             =head2 num_cols
213              
214             Returns the number of columns that will be in the table. This is calculated
215             from the list of people.
216              
217             It is unlikely that you will need to call this method.
218              
219             =cut
220             sub num_cols {
221 5     5 1 8 my $self = shift;
222              
223 5         10 return int log( $self->num_people ) / log(2) + 1;
224             }
225              
226             =head2 row
227              
228             Returns the HTML that makes up one row in the table.
229              
230             It is unlikely that you will need to call this method.
231              
232             =cut
233              
234             sub row {
235 8     8 1 9 my $self = shift;
236 8         11 my ($rownum) = @_;
237              
238 8         9 my @cells;
239 8         10 my $rowspan = 1;
240 8         9 my $i = $rownum;
241              
242 8         122 my $label_method = $self->label_method;
243              
244 8         73 while (1) {
245 14 50       50 my $person = exists $self->people->{$i} ? $self->people->{$i} : undef;
246 14 100       32 my $class = $person ? $person->known ? 'success' : 'danger' : 'danger';
    50          
247 14 50       113 my $desc = "$i: " . ($person ? $person->$label_method : '');
248 14         49 my $td = qq[$desc
249 14         21 unshift @cells, $td;
250              
251 14 100       29 last if $i % 2;
252 6         7 $rowspan *= 2;
253 6         10 $i /= 2;
254             }
255              
256 8         32 return join '', "
257             }
258              
259             =head2 table_headers
260              
261             Calculates and returns the headers used in the table.
262              
263             =cut
264              
265             sub table_headers {
266 2     2 1 5 my $self = shift;
267              
268 2         3 my @headers;
269 2 50       4 if ($self->num_cols <= @{ $self->headers }) {
  2         43  
270 2         56 @headers = @{ $self->headers }[0 .. $self->num_cols - 1];
  2         28  
271             } else {
272 0         0 @headers = @{ $self->headers };
  0         0  
273 0         0 my $gt = 2;
274 0         0 for (@headers .. $self->num_cols - 1) {
275 0         0 push @headers, $gt++ . ' ' . $self->extra_header;
276             }
277             }
278              
279 2         22 return \@headers;
280             }
281              
282             =head2 chart
283              
284             Returns the complete HTML of the ancestor chart.
285              
286             =cut
287              
288             sub chart {
289 1     1 1 3 my $self = shift;
290              
291 1         3 my $headers = join "\n", map { "$_
  3         11  
  1         2  
292              
293 1         4 my $table = <
294             \n
295            
296            
297             $headers
298            
299            
300            
301             EOTABLE
302              
303 1         3 $table .= join '', $self->rows;
304              
305 1         4 $table .= "\n
";
306              
307 1         3 return $table;
308             }
309              
310             =head1 AUTHOR
311              
312             Dave Cross
313              
314             =head1 COPYRIGHT AND LICENCE
315              
316             Copyright (c) 2022, Magnum Solutions Ltd. All Rights Reserved.
317              
318             This library is free software; you can redistribute it and/or modify it
319             under the same terms as Perl itself.
320              
321             =cut
322              
323             1;