File Coverage

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

linestmtbrancondsubpodtimecode
1package HTML::Genealogy::Map;
2
3
3
3
3
3
173847
3
26
use strict;
4
3
3
3
3
3
1
39
use warnings;
5
6
3
3
3
3
424
200
5
use utf8;
7
8
3
3
3
3
199
373
6
use open qw(:std :encoding(UTF-8));
9
10
3
3
3
3
6366
8728
6
use autodie;
11
3
3
3
3
6046
1010381
69
use Date::Cmp;
12
3
3
3
3
496
18829
33
use HTML::GoogleMaps::V3;
13
3
3
3
3
625
95947
48
use HTML::OSM;
14
3
3
3
3
8
17
23
use Object::Configure 0.15;
15
3
3
3
3
3
10
37
use Params::Get 0.13;
16
3
3
3
3
4
7
33
use Params::Validate::Strict 0.16;
17
3
3
3
3
3
6
2394
use Scalar::Util qw(blessed);
18
19 - 27
=head1 NAME

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

=head1 VERSION

Version 0.06

=cut
28
29our $VERSION = '0.06';
30
31# The backends of Geo::Coder::Free that answer from a local database, named as
32# they put themselves in a result's 'database' key.
33my %LOCAL_DATABASES = map { $_ => 1 } qw(OpenAddresses MaxMind Local Geo::Coder::Free::Local);
34
35 - 124
=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.
Its results are read through the coordinates in C<lat> and C<long>/C<lng> -
through C<latitude()>/C<longitude()> when the geocoder returns an object -
so L<Geo::Location::Point> and anything else L<HTML::OSM> accepts will do.
A result's C<database> says which local dataset answered, and an
L<Geo::Coder::Free> result therefore does not attract the courtesy delay that
a remote service gets.

=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
125
126sub onload_render
127{
128
16
100
16
1
211983
        my $class = ref($_[0]) ? __PACKAGE__ : shift;
129
130        # Configuration
131
16
25
        my $params = Params::Validate::Strict::validate_strict({
132                args => Params::Get::get_params('gedcom', @_),
133                schema => {
134                        'gedcom' => { 'type' => 'object', 'can' => 'individuals' },
135                        'geocoder' => { 'type' => 'object', 'can' => 'geocode' },
136                        'debug' => { 'type' => 'boolean', optional => 1 },
137                        'google_key' => { 'type' => 'string', optional => 1, min => 39, max => 39, matches => qr/^AIza[0-9A-Za-z_-]{35}$/ },
138                        'height' => { optional => 1, type => 'string' },
139                        'width' => { optional => 1, type => 'string' },
140                }
141        });
142
143
13
2265
        $params = Object::Configure::configure($class, $params);
144
145
13
18462
        my $ged = $params->{'gedcom'};
146
13
12
        my $debug = $params->{'debug'};
147
13
9
        my $google_key = $params->{'google_key'};
148
13
10
        my $geocoder = $params->{'geocoder'};
149
13
100
23
        my $height = $params->{'height'} || '400px';
150
13
100
17
        my $width = $params->{'width'} || '600px';
151
152        # Storage for events
153
13
11
        my @events;
154
155
13
100
10
        print "Parsing GEDCOM file...\n" if($debug);
156
157        # Process all individuals
158
13
23
        foreach my $indi ($ged->individuals) {
159
12
50
31
                next unless(ref($indi));
160
12
50
15
                my $name = $indi->name || 'Unknown';
161
12
30
                $name =~ s/\///g;       # Remove GEDCOM name delimiters
162
12
11
                $name =~ s/'/&apos;/g;  # Probably this is enough HTML::Entities
163
164                # Birth events
165
12
100
15
                if (my $birth = $indi->birth) {
166
11
100
67
28
                        if (ref($birth) && (my $place = $birth->place)) {
167
10
50
25
                                push @events, {
168                                        type => 'birth',
169                                        name => $name,
170                                        place => $place,
171                                        date => $birth->date || 'Unknown date',
172                                };
173                        }
174                }
175
176                # Death events
177
12
100
33
                if (my $death = $indi->death) {
178
1
50
33
4
                        if (ref($death) && (my $place = $death->place)) {
179
1
50
4
                                push @events, {
180                                        type => 'death',
181                                        name => $name,
182                                        place => $place,
183                                        date => $death->date || 'Unknown date',
184                                };
185                        }
186                }
187        }
188
189        # Process all families (marriages)
190
13
35
        foreach my $fam ($ged->families) {
191
1
50
33
6
                next unless defined($fam) && ref($fam); # Yes, really
192
193
1
50
33
2
                my $husband = (ref($fam->husband) && $fam->husband->name) ? $fam->husband->name : 'Unknown';
194
1
50
33
14
                my $wife = (ref($fam->wife) && $fam->wife->name) ? $fam->wife->name : 'Unknown';
195
196
1
6
                $husband =~ s/\///g;
197
1
1
                $wife =~ s/\///g;
198
199
1
50
2
                if (my $marriage = $fam->marriage) {
200
1
50
33
6
                        if (ref($marriage) && (my $place = $marriage->place)) {
201
1
2
                                $husband =~ s/'/&apos;/;
202
1
1
                                $wife =~ s/'/&apos;/;
203
1
50
3
                                push @events, {
204                                        type => 'marriage',
205                                        name => "$husband &amp; $wife",
206                                        place => $place,
207                                        date => $marriage->date || 'Unknown date',
208                                };
209                        }
210                }
211        }
212
213
13
100
31
        print 'Found ', scalar(@events), " events with location data.\n" if($debug);
214
13
100
10
        print "Geocoding locations...\n" if($debug);
215
216        # Geocode all events
217
13
7
        my @geocoded_events;
218        my %cache;      # TODO allow use of params->{cache} if given
219
220
13
7
        foreach my $event (@events) {
221
12
12
                my $place = $event->{place};
222
223                # Check cache
224
12
100
14
                unless (exists $cache{$place}) {
225
11
11
                        my $location = $geocoder->geocode(location => $place);
226
11
170
                        my ($lat, $long) = _coordinates($location);
227
228
11
100
67
55
                        if (defined($lat) && defined($long)) {
229
10
15
                                $cache{$place} = {
230                                        lat => $lat,
231                                        lon => $long,        # The cache's own key, not a key of the result
232                                };
233
10
50
7
                                print "\tGeocoded: $place\n" if($debug);
234
10
100
14
                                sleep 1 unless _is_local($location);    # Be nice to geocoding service
235
236                        } else {
237
1
50
1
                                print "\tFailed to geocode: $place\n" if($debug);
238
1
1
                                $cache{$place} = undef;
239
1
1000123
                                sleep 1;        # Be nice to geocoding service
240                        }
241                }
242
243
12
100
105
                if ($cache{$place}) {
244                        push @geocoded_events, {
245                                %$event,
246                                lat => $cache{$place}{lat},
247                                lon => $cache{$place}{lon},
248
11
60
                        };
249                }
250        }
251
252
13
100
24
        print 'Successfully geocoded ', scalar(@geocoded_events), " events.\n" if($debug);
253
254
13
100
43
        return('', '') if(scalar(@geocoded_events) == 0);       # Empty
255
256
8
50
9
        print "Generating map...\n" if($debug);
257
258        # Group events by location
259
8
34
        my %location_groups;
260
8
8
        foreach my $event (@geocoded_events) {
261
11
69
                my $key = sprintf('%.6f,%.6f', $event->{lat}, $event->{lon});
262
11
11
9
15
                push @{$location_groups{$key}}, $event;
263        }
264
265        # Generate map based on available API key
266
8
6
        my $map;
267
8
50
9
        if ($google_key) {
268
0
0
                $map = _generate_google_map(\%location_groups, $height, $width, $google_key);
269        } else {
270
8
19
                $map = _generate_osm_map(\%location_groups, $height, $width);
271        }
272
273
8
13
        return $map->onload_render();
274}
275
276# Purpose:  Read the position out of a geocoder result.
277# Entry:    $location — a Geo::Location::Point (or anything else with
278#           latitude()/longitude(), which is what HTML::OSM accepts), or a
279#           plain hashref from another geocoder, or undef.
280# Exit:     ($lat, $lon) with either possibly undef; an empty list for a result
281#           that carries no position.
282sub _coordinates {
283
11
11
8
        my $location = shift;
284
285
11
100
11
        return unless defined($location);
286
287
10
50
50
26
        if(blessed($location) && $location->can('latitude') && $location->can('longitude')) {
288
6
6
                return ($location->latitude(), $location->longitude());
289        }
290
291
4
50
4
        if(ref($location) eq 'HASH') {
292                # lat/long/lng are the keys Geo::Location::Point itself builds; 'lon' is
293                # only a third fallback, for geocoders that spell longitude that way. It
294                # is not part of the point interface: only one of Geo::Coder::Free's
295                # MaxMind shortcuts ever sets it.
296                return ($location->{'lat'},
297
4
33
33
12
                        $location->{'long'} // $location->{'lng'} // $location->{'lon'});
298        }
299
300
0
0
        return;
301}
302
303# Purpose:  Is this result from a local dataset, so that it needs no courtesy
304#           delay before the next lookup?
305# Entry:    $location — a geocoder result.
306# Exit:     1 if it came from an offline database, 0 otherwise.
307sub _is_local {
308
10
10
4
        my $location = shift;
309
310
10
50
8
        return 0 unless ref($location);
311
10
50
8
        return 0 if(ref($location) eq 'ARRAY'); # A flat [lat, lon] says nothing about provenance
312
313        # 'database' is set by every Geo::Coder::Free backend and names the one that
314        # answered, in one of two vocabularies (%LOCAL_DATABASES holds both).
315        # 'geocoder' names the distribution instead: Geo::Coder::Free has set it since
316        # 0.45, and a wrapper such as Geo::Coder::List stamps it on its own results,
317        # so it is tested second - a result carrying neither key is not guessed to be
318        # local.
319
10
100
67
28
        return 1 if(defined($location->{'database'}) && $LOCAL_DATABASES{$location->{'database'}});
320
5
100
67
15
        return 1 if(defined($location->{'geocoder'}) && $location->{'geocoder'} =~ /^Geo::Coder::Free/);
321
322
3
3000355
        return 0;
323}
324
325# Generate HTML for grouped events
326sub _generate_popup_html {
327
10
10
7
        my ($events) = @_;
328
329
10
9
        my $place = $events->[0]{place};
330
10
5
        my $event_count = scalar(@$events);
331
332        # Add scrollable container if more than 5 events
333
10
10
        my $container_start = '';
334
10
6
        my $container_end = '';
335
10
50
13
        if ($event_count > 5) {
336
0
0
                $container_start = '<div style="max-height: 300px; overflow-y: auto;">';
337
0
0
                $container_end = '</div>';
338        }
339
340
10
8
        my $html = "<b>$place</b><br><br>$container_start";
341
342        # Group by type
343
10
6
        my %by_type;
344
10
8
        foreach my $event (@$events) {
345
11
11
8
14
                push @{$by_type{$event->{type}}}, $event;
346        }
347
348        # Sort function for dates
349        my $sort_by_date = sub {
350
1
1
1
                my $date_a = $a->{'date'};
351
1
1
                my $date_b = $b->{'date'};
352
353                # Put unknown dates at the end
354
1
50
33
4
                return 1 if $date_a =~ /^Unknown/i && $date_b !~ /^Unknown/i;
355
1
50
33
2
                return -1 if $date_b =~ /^Unknown/i && $date_a !~ /^Unknown/i;
356
1
50
33
2
                return 0 if $date_a =~ /^Unknown/i && $date_b =~ /^Unknown/i;
357
358
1
4
                return Date::Cmp::datecmp($date_a, $date_b);
359
10
15
        };
360
361        # Add births
362
10
100
12
        if ($by_type{birth}) {
363
8
6
                $html .= '<b>Births:</b><br>';
364
8
8
5
9
                foreach my $event (sort $sort_by_date @{$by_type{birth}}) {
365                        $html .= sprintf(
366                                '<span style="color: green; font-size: 20px;">&#x25CF;</span> %s (%s)<br>',
367                                $event->{name},
368                                $event->{date}
369
9
86
                        );
370                }
371
8
5
                $html .= '<br>';
372        }
373
374        # Add marriages
375
10
100
13
        if ($by_type{marriage}) {
376
1
1
                $html .= '<b>Marriages:</b><br>';
377
1
1
2
1
                foreach my $event (sort $sort_by_date @{$by_type{marriage}}) {
378                        $html .= sprintf(
379                                '<span style="color: blue; font-size: 20px;">&#x25CF;</span> %s (%s)<br>',
380                                $event->{name},
381                                $event->{date}
382
1
2
                        );
383                }
384
1
1
                $html .= '<br>';
385        }
386
387        # Add deaths
388
10
100
7
        if ($by_type{death}) {
389
1
1
                $html .= '<b>Deaths:</b><br>';
390
1
1
2
2
                foreach my $event (sort $sort_by_date @{$by_type{death}}) {
391                        $html .= sprintf(
392                                '<span style="color: red; font-size: 20px;">&#x25CF;</span> %s (%s)<br>',
393                                $event->{name},
394                                $event->{date}
395
1
1
                        );
396                }
397        }
398
399
10
10
        $html .= $container_end;
400
401
10
41
        return $html;
402}
403
404# Generate Google Maps
405sub _generate_google_map {
406
0
0
0
        my ($location_groups, $height, $width, $key) = @_;
407
408
0
0
        my $map = HTML::GoogleMaps::V3->new(
409                key => $key,
410                height => $height,
411                width => $width
412        );
413
414        # Add markers for each location
415
0
0
        my $first = 1;
416
0
0
        foreach my $loc_key (keys %$location_groups) {
417
0
0
                my $events = $location_groups->{$loc_key};
418
0
0
                my ($lat, $lon) = split /,/, $loc_key;
419
420
0
0
                my $html = _generate_popup_html($events);
421
422
0
0
                $map->add_marker(
423                        point => [$lat, $lon],
424                        html => $html,
425                );
426
427                # Center on first location
428
0
0
0
                if ($first) {
429
0
0
                        $map->center([$lat, $lon]);
430
0
0
                        $map->zoom(4);
431
0
0
                        $first = 0;
432                }
433        }
434
435
0
0
        return $map;
436}
437
438# Generate OpenStreetMap using HTML::OSM
439sub _generate_osm_map {
440
8
8
10
        my ($location_groups, $height, $width) = @_;
441
442        # Create HTML::OSM object
443
8
35
        my $osm = HTML::OSM->new(zoom => 12, height => $height, width => $width);
444
445        # Add markers for each location
446
8
82065
        foreach my $loc_key (keys %$location_groups) {
447
10
79
                my $events = $location_groups->{$loc_key};
448
10
16
                my ($lat, $lon) = split /,/, $loc_key;
449
450
10
14
                my $html = _generate_popup_html($events);
451
452
10
17
                $osm->add_marker(
453                        point => [$lat, $lon],
454                        html => $html,
455                );
456        }
457
458        # Find location with most events
459
8
261
        my ($center_lat, $center_lon) = (0, 0);
460
8
5
        my $max_events = 0;
461
8
8
        foreach my $loc_key (keys %$location_groups) {
462
10
10
4
14
                my $event_count = scalar(@{$location_groups->{$loc_key}});
463
10
100
10
                if ($event_count > $max_events) {
464
8
6
                        $max_events = $event_count;
465
8
10
                        ($center_lat, $center_lon) = split /,/, $loc_key;
466                }
467        }
468
469
8
18
        $osm->center([$center_lat, $center_lon]);
470
471
8
198
        return $osm;
472}
473
474 - 538
=head1 BUGS

=head1 SEE ALSO

=over 4

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

=item * L<Configure an Object at Runtime|Object::Configure>

=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 AUTHOR

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

=head1 LICENCE AND COPYRIGHT

Copyright 2025-2026 Nigel Horne.

Usage is subject to the GPL2 licence terms.
If you use it,
please let me know.

=cut
539
5401;