| File: | blib/lib/HTML/Genealogy/Map.pm |
| Coverage: | 80.3% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package HTML::Genealogy::Map; | |||||
| 2 | ||||||
| 3 | 3 3 3 | 225511 3 38 | use strict; | |||
| 4 | 3 3 3 | 5 2 53 | use warnings; | |||
| 5 | ||||||
| 6 | 3 3 3 | 390 174 6 | use utf8; | |||
| 7 | ||||||
| 8 | 3 3 3 | 226 466 8 | use open qw(:std :encoding(UTF-8)); | |||
| 9 | ||||||
| 10 | 3 3 3 | 8267 17452 6 | use autodie; | |||
| 11 | 3 3 3 | 8091 1053782 96 | use Date::Cmp; | |||
| 12 | 3 3 3 | 664 25496 51 | use HTML::GoogleMaps::V3; | |||
| 13 | 3 3 3 | 665 203404 64 | use HTML::OSM; | |||
| 14 | 3 3 3 | 10 26 28 | use Object::Configure 0.15; | |||
| 15 | 3 3 3 | 5 2 45 | use Params::Get; | |||
| 16 | 3 3 3 | 5 20 2811 | 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.03 =cut | |||||
| 27 | ||||||
| 28 | our $VERSION = '0.03'; | |||||
| 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 | ||||||
| 115 | sub onload_render | |||||
| 116 | { | |||||
| 117 | 91 | 310395 | my $class = shift; | |||
| 118 | ||||||
| 119 | # Configuration | |||||
| 120 | 91 | 134 | 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 | 7540 | $params = Object::Configure::configure($class, $params); | |||
| 133 | ||||||
| 134 | 71 | 142102 | my $ged = $params->{'gedcom'}; | |||
| 135 | 71 | 62 | my $debug = $params->{'debug'}; | |||
| 136 | 71 | 56 | my $google_key = $params->{'google_key'}; | |||
| 137 | 71 | 44 | my $geocoder = $params->{'geocoder'}; | |||
| 138 | 71 | 132 | my $height = $params->{'height'} || '400px'; | |||
| 139 | 71 | 87 | my $width = $params->{'width'} || '600px'; | |||
| 140 | ||||||
| 141 | # Storage for events | |||||
| 142 | 71 | 44 | my @events; | |||
| 143 | ||||||
| 144 | 71 | 338 | print "Parsing GEDCOM file...\n" if($debug); | |||
| 145 | ||||||
| 146 | # Process all individuals | |||||
| 147 | 71 | 105 | foreach my $indi ($ged->individuals) { | |||
| 148 | 68 | 375 | next unless(ref($indi)); | |||
| 149 | 6 | 10 | my $name = $indi->name || 'Unknown'; | |||
| 150 | 6 | 19 | $name =~ s/\///g; # Remove GEDCOM name delimiters | |||
| 151 | 6 | 5 | $name =~ s/'/'/g; # Probably this is enough HTML::Entities | |||
| 152 | ||||||
| 153 | # Birth events | |||||
| 154 | 6 | 8 | if (my $birth = $indi->birth) { | |||
| 155 | 5 | 18 | if (ref($birth) && (my $place = $birth->place)) { | |||
| 156 | 4 | 14 | 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 | 25 | if (my $death = $indi->death) { | |||
| 167 | 1 | 5 | if (ref($death) && (my $place = $death->place)) { | |||
| 168 | 1 | 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 | 109 | foreach my $fam ($ged->families) { | |||
| 180 | 63 | 312 | next unless defined($fam) && ref($fam); # Yes, really | |||
| 181 | ||||||
| 182 | 1 | 2 | my $husband = (ref($fam->husband) && $fam->husband->name) ? $fam->husband->name : 'Unknown'; | |||
| 183 | 1 | 12 | my $wife = (ref($fam->wife) && $fam->wife->name) ? $fam->wife->name : 'Unknown'; | |||
| 184 | ||||||
| 185 | 1 | 8 | $husband =~ s/\///g; | |||
| 186 | 1 | 2 | $wife =~ s/\///g; | |||
| 187 | ||||||
| 188 | 1 | 2 | if (my $marriage = $fam->marriage) { | |||
| 189 | 1 | 5 | if (ref($marriage) && (my $place = $marriage->place)) { | |||
| 190 | 1 | 3 | $husband =~ s/'/'/; | |||
| 191 | 1 | 1 | $wife =~ s/'/'/; | |||
| 192 | 1 | 4 | push @events, { | |||
| 193 | type => 'marriage', | |||||
| 194 | name => "$husband & $wife", | |||||
| 195 | place => $place, | |||||
| 196 | date => $marriage->date || 'Unknown date', | |||||
| 197 | }; | |||||
| 198 | } | |||||
| 199 | } | |||||
| 200 | } | |||||
| 201 | ||||||
| 202 | 71 | 153 | print 'Found ', scalar(@events), " events with location data.\n" if($debug); | |||
| 203 | 71 | 99 | print "Geocoding locations...\n" if($debug); | |||
| 204 | ||||||
| 205 | # Geocode all events | |||||
| 206 | 71 | 58 | my @geocoded_events; | |||
| 207 | my %cache; # TODO allow use of params->{cache} if given | |||||
| 208 | ||||||
| 209 | 71 | 57 | foreach my $event (@events) { | |||
| 210 | 6 | 7 | my $place = $event->{place}; | |||
| 211 | ||||||
| 212 | # Check cache | |||||
| 213 | 6 | 10 | unless (exists $cache{$place}) { | |||
| 214 | 5 | 8 | my $location = $geocoder->geocode(location => $place); | |||
| 215 | 5 | 63 | if ($location && $location->{lat} && $location->{lon}) { | |||
| 216 | $cache{$place} = { | |||||
| 217 | lat => $location->{lat}, | |||||
| 218 | lon => $location->{lon}, | |||||
| 219 | 4 | 8 | }; | |||
| 220 | 4 | 5 | print "\tGeocoded: $place\n" if($debug); | |||
| 221 | 4 | 3000403 | sleep 1 if($location->{'geocoder'} !~ /^Geo::Coder::Free/); # Be nice to geocoding service | |||
| 222 | ||||||
| 223 | } else { | |||||
| 224 | 1 | 1 | print "\tFailed to geocode: $place\n" if($debug); | |||
| 225 | 1 | 2 | $cache{$place} = undef; | |||
| 226 | 1 | 1000081 | sleep 1; # Be nice to geocoding service | |||
| 227 | } | |||||
| 228 | } | |||||
| 229 | ||||||
| 230 | 6 | 44 | if ($cache{$place}) { | |||
| 231 | push @geocoded_events, { | |||||
| 232 | %$event, | |||||
| 233 | lat => $cache{$place}{lat}, | |||||
| 234 | lon => $cache{$place}{lon}, | |||||
| 235 | 5 | 59 | }; | |||
| 236 | } | |||||
| 237 | } | |||||
| 238 | ||||||
| 239 | 71 | 108 | print 'Successfully geocoded ', scalar(@geocoded_events), " events.\n" if($debug); | |||
| 240 | ||||||
| 241 | 71 | 193 | return('', '') if(scalar(@geocoded_events) == 0); # Empty | |||
| 242 | ||||||
| 243 | 4 | 20 | print "Generating map...\n" if($debug); | |||
| 244 | ||||||
| 245 | # Group events by location | |||||
| 246 | 4 | 6 | my %location_groups; | |||
| 247 | 4 | 7 | foreach my $event (@geocoded_events) { | |||
| 248 | 5 | 45 | my $key = sprintf('%.6f,%.6f', $event->{lat}, $event->{lon}); | |||
| 249 | 5 5 | 6 13 | push @{$location_groups{$key}}, $event; | |||
| 250 | } | |||||
| 251 | ||||||
| 252 | # Generate map based on available API key | |||||
| 253 | 4 | 21 | my $map; | |||
| 254 | 4 | 11 | if ($google_key) { | |||
| 255 | 0 | 0 | $map = generate_google_map(\%location_groups, $height, $width, $google_key); | |||
| 256 | } else { | |||||
| 257 | 4 | 14 | $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 | |||||
| 264 | sub generate_popup_html { | |||||
| 265 | 4 | 6 | my ($events) = @_; | |||
| 266 | ||||||
| 267 | 4 | 5 | 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 | 4 | my $container_start = ''; | |||
| 272 | 4 | 4 | my $container_end = ''; | |||
| 273 | 4 | 8 | 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 | 5 | my $html = "<b>$place</b><br><br>$container_start"; | |||
| 279 | ||||||
| 280 | # Group by type | |||||
| 281 | 4 | 4 | my %by_type; | |||
| 282 | 4 | 4 | foreach my $event (@$events) { | |||
| 283 | 5 5 | 4 8 | push @{$by_type{$event->{type}}}, $event; | |||
| 284 | } | |||||
| 285 | ||||||
| 286 | # Sort function for dates | |||||
| 287 | my $sort_by_date = sub { | |||||
| 288 | 1 | 1 | my $date_a = $a->{'date'}; | |||
| 289 | 1 | 2 | my $date_b = $b->{'date'}; | |||
| 290 | ||||||
| 291 | # Put unknown dates at the end | |||||
| 292 | 1 | 3 | return 1 if $date_a =~ /^Unknown/i && $date_b !~ /^Unknown/i; | |||
| 293 | 1 | 3 | return -1 if $date_b =~ /^Unknown/i && $date_a !~ /^Unknown/i; | |||
| 294 | 1 | 6 | return 0 if $date_a =~ /^Unknown/i && $date_b =~ /^Unknown/i; | |||
| 295 | ||||||
| 296 | 1 | 5 | return Date::Cmp::datecmp($date_a, $date_b); | |||
| 297 | 4 | 11 | }; | |||
| 298 | ||||||
| 299 | # Add births | |||||
| 300 | 4 | 6 | if ($by_type{birth}) { | |||
| 301 | 2 | 2 | $html .= '<b>Births:</b><br>'; | |||
| 302 | 2 2 | 2 4 | foreach my $event (sort $sort_by_date @{$by_type{birth}}) { | |||
| 303 | $html .= sprintf( | |||||
| 304 | '<span style="color: green; font-size: 20px;">●</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 | 5 | 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;">●</span> %s (%s)<br>', | |||||
| 318 | $event->{name}, | |||||
| 319 | $event->{date} | |||||
| 320 | 1 | 2 | ); | |||
| 321 | } | |||||
| 322 | 1 | 1 | $html .= '<br>'; | |||
| 323 | } | |||||
| 324 | ||||||
| 325 | # Add deaths | |||||
| 326 | 4 | 6 | if ($by_type{death}) { | |||
| 327 | 1 | 1 | $html .= '<b>Deaths:</b><br>'; | |||
| 328 | 1 1 | 40 3 | foreach my $event (sort $sort_by_date @{$by_type{death}}) { | |||
| 329 | $html .= sprintf( | |||||
| 330 | '<span style="color: red; font-size: 20px;">●</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 | 15 | return $html; | |||
| 340 | } | |||||
| 341 | ||||||
| 342 | # Generate Google Maps | |||||
| 343 | sub generate_google_map { | |||||
| 344 | 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 | 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 | |||||
| 377 | sub generate_osm_map { | |||||
| 378 | 4 | 8 | my ($location_groups, $height, $width) = @_; | |||
| 379 | ||||||
| 380 | # Create HTML::OSM object | |||||
| 381 | 4 | 27 | my $osm = HTML::OSM->new(zoom => 12, height => $height, width => $width); | |||
| 382 | ||||||
| 383 | # Add markers for each location | |||||
| 384 | 4 | 53686 | foreach my $loc_key (keys %$location_groups) { | |||
| 385 | 4 | 6 | my $events = $location_groups->{$loc_key}; | |||
| 386 | 4 | 8 | my ($lat, $lon) = split /,/, $loc_key; | |||
| 387 | ||||||
| 388 | 4 | 14 | my $html = generate_popup_html($events); | |||
| 389 | ||||||
| 390 | 4 | 12 | $osm->add_marker( | |||
| 391 | point => [$lat, $lon], | |||||
| 392 | html => $html, | |||||
| 393 | ); | |||||
| 394 | } | |||||
| 395 | ||||||
| 396 | # Find location with most events | |||||
| 397 | 4 | 157 | my ($center_lat, $center_lon) = (0, 0); | |||
| 398 | 4 | 2 | my $max_events = 0; | |||
| 399 | 4 | 7 | foreach my $loc_key (keys %$location_groups) { | |||
| 400 | 4 4 | 2 4 | my $event_count = scalar(@{$location_groups->{$loc_key}}); | |||
| 401 | 4 | 5 | if ($event_count > $max_events) { | |||
| 402 | 4 | 2 | $max_events = $event_count; | |||
| 403 | 4 | 7 | ($center_lat, $center_lon) = split /,/, $loc_key; | |||
| 404 | } | |||||
| 405 | } | |||||
| 406 | ||||||
| 407 | 4 | 8 | $osm->center([$center_lat, $center_lon]); | |||
| 408 | ||||||
| 409 | 4 | 107 | 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 | ||||||
| 490 | 1; | |||||