File Coverage

File:blib/lib/HTML/Genealogy/Map.pm
Coverage:80.3%

linestmtbrancondsubtimecode
1package HTML::Genealogy::Map;
2
3
3
3
3
3
222023
2
39
use strict;
4
3
3
3
3
4
2
48
use warnings;
5
6
3
3
3
3
371
174
5
use utf8;
7
8
3
3
3
3
234
487
7
use open qw(:std :encoding(UTF-8));
9
10
3
3
3
3
8185
17024
6
use autodie;
11
3
3
3
3
7964
1029733
81
use Date::Cmp;
12
3
3
3
3
628
24811
48
use HTML::GoogleMaps::V3;
13
3
3
3
3
662
201367
63
use HTML::OSM;
14
3
3
3
3
10
43
35
use Object::Configure 0.15;
15
3
3
3
3
5
13
45
use Params::Get 0.13;
16
3
3
3
3
7
20
2764
use Params::Validate::Strict 0.16;
17
18 - 26
=head1 NAME

HTML::Genealogy::Map - Extract and map genealogical events from a GEDCOM file

=head1 VERSION

Version 0.04

=cut
27
28our $VERSION = '0.04';
29
30 - 113
=head1 DESCRIPTION

This module parses GEDCOM genealogy files and creates an interactive map showing
the locations of births, marriages, and deaths. Events at the same location are
grouped together in a single marker with a scrollable popup.

=head1 SUBROUTINES/METHODS

=head2 onload_render

Render the map.
It takes two mandatory and one optional parameter.
It returns an array of two elements, the items for the C<head> and C<body>.

=over 4

=item B<gedcom>

L<GEDCOM> object to process.

=item B<geocoder>

Geocoder to use.

=item B<google_key>

Key to Google's map API.

=item B<debug>

Enable print statements of what's going on

=back

=head1 FEATURES

=over 4

=item * Extracts births, marriages, and deaths with location data

=item * Geocodes locations using multiple fallback providers

=item * Groups events at the same location (within ~0.1m precision)

=item * Color-coded event indicators (green=birth, blue=marriage, red=death)

=item * Sorts events chronologically within each category

=item * Scrollable popups for locations with more than 5 events

=item * Persistent caching of geocoding results

=item * For OpenStreetMap: centers on location with most events

=back

=head3  API SPECIFICATION

=head4  INPUT

  {
    'gedcom' => { 'type' => 'object', 'can' => 'individuals' },
    'geocoder' => { 'type' => 'object', 'can' => 'geocode' },
    'debug' => { 'type' => 'boolean', optional => 1 },
    'google_key' => { 'type' => 'string', optional => 1, min => 39, max => 39, matches => qr/^AIza[0-9A-Za-z_-]{35}$/ },
    'height' => { optional => 1 },
    'width' => { optional => 1 }
  }

=head4  OUTPUT

Argument error: croak
No matches found: undef

Returns an array of two strings:

  {
    'type' => 'array',
    'min' => 2,
    'max' => 2,
    'schema' => { 'type' => 'string', min => 10 },
  }

=cut
114
115sub onload_render
116{
117
101
101
311039
        my $class = shift;
118
119        # Configuration
120
101
141
        my $params = Params::Validate::Strict::validate_strict({
121                args => Params::Get::get_params('gedcom', @_),
122                schema => {
123                        'gedcom' => { 'type' => 'object', 'can' => 'individuals' },
124                        'geocoder' => { 'type' => 'object', 'can' => 'geocode' },
125                        'debug' => { 'type' => 'boolean', optional => 1 },
126                        'google_key' => { 'type' => 'string', optional => 1, min => 39, max => 39, matches => qr/^AIza[0-9A-Za-z_-]{35}$/ },
127                        'height' => { optional => 1 },
128                        'width' => { optional => 1 },
129                }
130        });
131
132
71
8342
        $params = Object::Configure::configure($class, $params);
133
134
71
143643
        my $ged = $params->{'gedcom'};
135
71
51
        my $debug = $params->{'debug'};
136
71
47
        my $google_key = $params->{'google_key'};
137
71
52
        my $geocoder = $params->{'geocoder'};
138
71
50
121
        my $height = $params->{'height'} || '400px';
139
71
50
88
        my $width = $params->{'width'} || '600px';
140
141        # Storage for events
142
71
39
        my @events;
143
144
71
100
274
        print "Parsing GEDCOM file...\n" if($debug);
145
146        # Process all individuals
147
71
95
        foreach my $indi ($ged->individuals) {
148
68
100
350
                next unless(ref($indi));
149
6
50
10
                my $name = $indi->name || 'Unknown';
150
6
21
                $name =~ s/\///g;       # Remove GEDCOM name delimiters
151
6
5
                $name =~ s/'/&apos;/g;  # Probably this is enough HTML::Entities
152
153                # Birth events
154
6
100
8
                if (my $birth = $indi->birth) {
155
5
100
67
18
                        if (ref($birth) && (my $place = $birth->place)) {
156
4
50
11
                                push @events, {
157                                        type => 'birth',
158                                        name => $name,
159                                        place => $place,
160                                        date => $birth->date || 'Unknown date',
161                                };
162                        }
163                }
164
165                # Death events
166
6
100
21
                if (my $death = $indi->death) {
167
1
50
33
6
                        if (ref($death) && (my $place = $death->place)) {
168
1
50
5
                                push @events, {
169                                        type => 'death',
170                                        name => $name,
171                                        place => $place,
172                                        date => $death->date || 'Unknown date',
173                                };
174                        }
175                }
176        }
177
178        # Process all families (marriages)
179
71
92
        foreach my $fam ($ged->families) {
180
63
100
67
267
                next unless defined($fam) && ref($fam); # Yes, really
181
182
1
50
33
2
                my $husband = (ref($fam->husband) && $fam->husband->name) ? $fam->husband->name : 'Unknown';
183
1
50
33
13
                my $wife = (ref($fam->wife) && $fam->wife->name) ? $fam->wife->name : 'Unknown';
184
185
1
7
                $husband =~ s/\///g;
186
1
2
                $wife =~ s/\///g;
187
188
1
50
2
                if (my $marriage = $fam->marriage) {
189
1
50
33
4
                        if (ref($marriage) && (my $place = $marriage->place)) {
190
1
3
                                $husband =~ s/'/&apos;/;
191
1
1
                                $wife =~ s/'/&apos;/;
192
1
50
6
                                push @events, {
193                                        type => 'marriage',
194                                        name => "$husband &amp; $wife",
195                                        place => $place,
196                                        date => $marriage->date || 'Unknown date',
197                                };
198                        }
199                }
200        }
201
202
71
100
125
        print 'Found ', scalar(@events), " events with location data.\n" if($debug);
203
71
100
75
        print "Geocoding locations...\n" if($debug);
204
205        # Geocode all events
206
71
43
        my @geocoded_events;
207        my %cache;      # TODO allow use of params->{cache} if given
208
209
71
56
        foreach my $event (@events) {
210
6
6
                my $place = $event->{place};
211
212                # Check cache
213
6
100
11
                unless (exists $cache{$place}) {
214
5
8
                        my $location = $geocoder->geocode(location => $place);
215
5
100
50
39
                        if ($location && $location->{lat} && $location->{lon}) {
216                                $cache{$place} = {
217                                        lat => $location->{lat},
218                                        lon => $location->{lon},
219
4
6
                                };
220
4
50
4
                                print "\tGeocoded: $place\n" if($debug);
221
4
100
3000350
                                sleep 1 if($location->{'geocoder'} !~ /^Geo::Coder::Free/);  # Be nice to geocoding service
222
223                        } else {
224
1
50
1
                                print "\tFailed to geocode: $place\n" if($debug);
225
1
2
                                $cache{$place} = undef;
226
1
1000100
                                sleep 1;        # Be nice to geocoding service
227                        }
228                }
229
230
6
100
48
                if ($cache{$place}) {
231                        push @geocoded_events, {
232                                %$event,
233                                lat => $cache{$place}{lat},
234                                lon => $cache{$place}{lon},
235
5
53
                        };
236                }
237        }
238
239
71
100
88
        print 'Successfully geocoded ', scalar(@geocoded_events), " events.\n" if($debug);
240
241
71
100
185
        return('', '') if(scalar(@geocoded_events) == 0);       # Empty
242
243
4
50
6
        print "Generating map...\n" if($debug);
244
245        # Group events by location
246
4
3
        my %location_groups;
247
4
8
        foreach my $event (@geocoded_events) {
248
5
45
                my $key = sprintf('%.6f,%.6f', $event->{lat}, $event->{lon});
249
5
5
18
13
                push @{$location_groups{$key}}, $event;
250        }
251
252        # Generate map based on available API key
253
4
4
        my $map;
254
4
50
9
        if ($google_key) {
255
0
0
                $map = _generate_google_map(\%location_groups, $height, $width, $google_key);
256        } else {
257
4
9
                $map = _generate_osm_map(\%location_groups, $height, $width);
258        }
259
260
4
7
        return $map->onload_render();
261}
262
263# Generate HTML for grouped events
264sub _generate_popup_html {
265
4
4
5
        my ($events) = @_;
266
267
4
6
        my $place = $events->[0]{place};
268
4
4
        my $event_count = scalar(@$events);
269
270        # Add scrollable container if more than 5 events
271
4
5
        my $container_start = '';
272
4
4
        my $container_end = '';
273
4
50
10
        if ($event_count > 5) {
274
0
0
                $container_start = '<div style="max-height: 300px; overflow-y: auto;">';
275
0
0
                $container_end = '</div>';
276        }
277
278
4
6
        my $html = "<b>$place</b><br><br>$container_start";
279
280        # Group by type
281
4
1
        my %by_type;
282
4
5
        foreach my $event (@$events) {
283
5
5
5
6
                push @{$by_type{$event->{type}}}, $event;
284        }
285
286        # Sort function for dates
287        my $sort_by_date = sub {
288
1
1
1
                my $date_a = $a->{'date'};
289
1
1
                my $date_b = $b->{'date'};
290
291                # Put unknown dates at the end
292
1
50
33
3
                return 1 if $date_a =~ /^Unknown/i && $date_b !~ /^Unknown/i;
293
1
50
33
3
                return -1 if $date_b =~ /^Unknown/i && $date_a !~ /^Unknown/i;
294
1
50
33
6
                return 0 if $date_a =~ /^Unknown/i && $date_b =~ /^Unknown/i;
295
296
1
4
                return Date::Cmp::datecmp($date_a, $date_b);
297
4
11
        };
298
299        # Add births
300
4
100
6
        if ($by_type{birth}) {
301
2
2
                $html .= '<b>Births:</b><br>';
302
2
2
2
5
                foreach my $event (sort $sort_by_date @{$by_type{birth}}) {
303                        $html .= sprintf(
304                                '<span style="color: green; font-size: 20px;">&#x25CF;</span> %s (%s)<br>',
305                                $event->{name},
306                                $event->{date}
307
3
25
                        );
308                }
309
2
2
                $html .= '<br>';
310        }
311
312        # Add marriages
313
4
100
7
        if ($by_type{marriage}) {
314
1
1
                $html .= '<b>Marriages:</b><br>';
315
1
1
1
1
                foreach my $event (sort $sort_by_date @{$by_type{marriage}}) {
316                        $html .= sprintf(
317                                '<span style="color: blue; font-size: 20px;">&#x25CF;</span> %s (%s)<br>',
318                                $event->{name},
319                                $event->{date}
320
1
2
                        );
321                }
322
1
0
                $html .= '<br>';
323        }
324
325        # Add deaths
326
4
100
5
        if ($by_type{death}) {
327
1
1
                $html .= '<b>Deaths:</b><br>';
328
1
1
1
12
                foreach my $event (sort $sort_by_date @{$by_type{death}}) {
329                        $html .= sprintf(
330                                '<span style="color: red; font-size: 20px;">&#x25CF;</span> %s (%s)<br>',
331                                $event->{name},
332                                $event->{date}
333
1
2
                        );
334                }
335        }
336
337
4
4
        $html .= $container_end;
338
339
4
16
        return $html;
340}
341
342# Generate Google Maps
343sub _generate_google_map {
344
0
0
0
        my ($location_groups, $height, $width, $key) = @_;
345
346
0
0
        my $map = HTML::GoogleMaps::V3->new(
347                key => $key,
348                height => $height,
349                width => $width
350        );
351
352        # Add markers for each location
353
0
0
        my $first = 1;
354
0
0
        foreach my $loc_key (keys %$location_groups) {
355
0
0
                my $events = $location_groups->{$loc_key};
356
0
0
                my ($lat, $lon) = split /,/, $loc_key;
357
358
0
0
                my $html = _generate_popup_html($events);
359
360
0
0
                $map->add_marker(
361                        point => [$lat, $lon],
362                        html => $html,
363                );
364
365                # Center on first location
366
0
0
0
                if ($first) {
367
0
0
                        $map->center([$lat, $lon]);
368
0
0
                        $map->zoom(4);
369
0
0
                        $first = 0;
370                }
371        }
372
373
0
0
        return $map;
374}
375
376# Generate OpenStreetMap using HTML::OSM
377sub _generate_osm_map {
378
4
4
8
        my ($location_groups, $height, $width) = @_;
379
380        # Create HTML::OSM object
381
4
26
        my $osm = HTML::OSM->new(zoom => 12, height => $height, width => $width);
382
383        # Add markers for each location
384
4
52457
        foreach my $loc_key (keys %$location_groups) {
385
4
5
                my $events = $location_groups->{$loc_key};
386
4
11
                my ($lat, $lon) = split /,/, $loc_key;
387
388
4
16
                my $html = _generate_popup_html($events);
389
390
4
11
                $osm->add_marker(
391                        point => [$lat, $lon],
392                        html => $html,
393                );
394        }
395
396        # Find location with most events
397
4
149
        my ($center_lat, $center_lon) = (0, 0);
398
4
3
        my $max_events = 0;
399
4
5
        foreach my $loc_key (keys %$location_groups) {
400
4
4
4
3
                my $event_count = scalar(@{$location_groups->{$loc_key}});
401
4
50
4
                if ($event_count > $max_events) {
402
4
4
                        $max_events = $event_count;
403
4
8
                        ($center_lat, $center_lon) = split /,/, $loc_key;
404                }
405        }
406
407
4
8
        $osm->center([$center_lat, $center_lon]);
408
409
4
105
        return $osm;
410}
411
412 - 488
=head1 AUTHOR

Nigel Horne, C<< <njh at nigelhorne.com> >>

=head1 BUGS

=head1 SEE ALSO

=over 4

=item * Test coverage report: L<https://nigelhorne.github.io/HTML-Genealogy-Map/coverage/>

=item * L<Object::Configure>

The class is fully configurable at runtime with configuration files.

=back

=head1 REPOSITORY

L<https://github.com/nigelhorne/HTML-Genealogy-Map>

=head1 SUPPORT

This module is provided as-is without any warranty.

Please report any bugs or feature requests to C<bug-html-genealogy-map at rt.cpan.org>,
or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=HTML-Genealogy-Map>.
I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

You can find documentation for this module with the perldoc command.

    perldoc HTML::Genalogy::Map

You can also look for information at:

=over 4

=item * MetaCPAN

L<https://metacpan.org/dist/HTML-Genealogy-Map>

=item * RT: CPAN's request tracker

L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=HTML-Genealogy-Map>

=item * CPAN Testers' Matrix

L<http://matrix.cpantesters.org/?dist=HTML-Genealogy-Map>

=item * CPAN Testers Dependencies

L<http://deps.cpantesters.org/?module=HTML::Genalogy::Map>

=back

=head1 LICENCE AND COPYRIGHT

Copyright 2025 Nigel Horne.

Usage is subject to licence terms.

The licence terms of this software are as follows:

=over 4

=item * Personal single user, single computer use: GPL2

=item * All other users (including Commercial, Charity, Educational, Government)
  must apply in writing for a licence for use from Nigel Horne at the
  above e-mail.

=back

=cut
489
4901;