lib/HTML/Genealogy/Map.pm

Index
Structural Coverage (Approximate)

TER1 (Statement): 90.61%
TER2 (Branch): 73.75%
TER3 (LCSAJ): 93.3% (14/15)
Approximate LCSAJ segments: 81

LCSAJ Legend

● Covered — this LCSAJ path was executed during testing.

● Not covered — this LCSAJ path was never executed. These are the paths to focus on.

Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows: 

        start → end → jump

Uncovered paths show [NOT COVERED] in the tooltip.

Mutant Testing Legend

Survived (tests missed this) Killed (tests detected this) No mutation 
    1: package HTML::Genealogy::Map;
    2: 
    3: use strict;
    4: use warnings;
    5: 
    6: use utf8;
    7: 
    8: use open qw(:std :encoding(UTF-8));
    9: 
   10: use autodie;
   11: use Date::Cmp;
   12: use HTML::GoogleMaps::V3;
   13: use HTML::OSM;
   14: use Object::Configure 0.15;
   15: use Params::Get 0.13;
   16: use Params::Validate::Strict 0.16;
   17: use Scalar::Util qw(blessed);
   18: 
   19: =head1 NAME
   20: 
   21: HTML::Genealogy::Map - Extract and map genealogical events from a GEDCOM file
   22: 
   23: =head1 VERSION
   24: 
   25: Version 0.06
   26: 
   27: =cut
   28: 
   29: our $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.
   33: my %LOCAL_DATABASES = map { $_ => 1 } qw(OpenAddresses MaxMind Local Geo::Coder::Free::Local);
   34: 
   35: =head1 DESCRIPTION
   36: 
   37: This module parses GEDCOM genealogy files and creates an interactive map showing
   38: the locations of births, marriages, and deaths. Events at the same location are
   39: grouped together in a single marker with a scrollable popup.
   40: 
   41: =head1 SUBROUTINES/METHODS
   42: 
   43: =head2 onload_render
   44: 
   45: Render the map.
   46: It takes two mandatory and one optional parameter.
   47: It returns an array of two elements, the items for the C<head> and C<body>.
   48: 
   49: =over 4
   50: 
   51: =item B<gedcom>
   52: 
   53: L<GEDCOM> object to process.
   54: 
   55: =item B<geocoder>
   56: 
   57: Geocoder to use.
   58: Its results are read through the coordinates in C<lat> and C<long>/C<lng> -
   59: through C<latitude()>/C<longitude()> when the geocoder returns an object -
   60: so L<Geo::Location::Point> and anything else L<HTML::OSM> accepts will do.
   61: A result's C<database> says which local dataset answered, and an
   62: L<Geo::Coder::Free> result therefore does not attract the courtesy delay that
   63: a remote service gets.
   64: 
   65: =item B<google_key>
   66: 
   67: Key to Google's map API.
   68: 
   69: =item B<debug>
   70: 
   71: Enable print statements of what's going on
   72: 
   73: =back
   74: 
   75: =head1 FEATURES
   76: 
   77: =over 4
   78: 
   79: =item * Extracts births, marriages, and deaths with location data
   80: 
   81: =item * Geocodes locations using multiple fallback providers
   82: 
   83: =item * Groups events at the same location (within ~0.1m precision)
   84: 
   85: =item * Color-coded event indicators (green=birth, blue=marriage, red=death)
   86: 
   87: =item * Sorts events chronologically within each category
   88: 
   89: =item * Scrollable popups for locations with more than 5 events
   90: 
   91: =item * Persistent caching of geocoding results
   92: 
   93: =item * For OpenStreetMap: centers on location with most events
   94: 
   95: =back
   96: 
   97: =head3	API SPECIFICATION
   98: 
   99: =head4	INPUT
  100: 
  101:   {
  102:     'gedcom' => { 'type' => 'object', 'can' => 'individuals' },
  103:     'geocoder' => { 'type' => 'object', 'can' => 'geocode' },
  104:     'debug' => { 'type' => 'boolean', optional => 1 },
  105:     'google_key' => { 'type' => 'string', optional => 1, min => 39, max => 39, matches => qr/^AIza[0-9A-Za-z_-]{35}$/ },
  106:     'height' => { optional => 1 },
  107:     'width' => { optional => 1 }
  108:   }
  109: 
  110: =head4	OUTPUT
  111: 
  112: Argument error: croak
  113: No matches found: undef
  114: 
  115: Returns an array of two strings:
  116: 
  117:   {
  118:     'type' => 'array',
  119:     'min' => 2,
  120:     'max' => 2,
  121:     'schema' => { 'type' => 'string', min => 10 },
  122:   }
  123: 
  124: =cut
  125: 
  126: sub onload_render
  127: {
●128 → 158 → 190  128: 	my $class = ref($_[0]) ? __PACKAGE__ : shift;
  129: 
  130: 	# Configuration
  131: 	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: 	$params = Object::Configure::configure($class, $params);
  144: 
  145: 	my $ged = $params->{'gedcom'};
  146: 	my $debug = $params->{'debug'};
  147: 	my $google_key = $params->{'google_key'};
  148: 	my $geocoder = $params->{'geocoder'};
  149: 	my $height = $params->{'height'} || '400px';
  150: 	my $width = $params->{'width'} || '600px';
  151: 
  152: 	# Storage for events
  153: 	my @events;
  154: 
  155: 	print "Parsing GEDCOM file...\n" if($debug);
  156: 
  157: 	# Process all individuals
  158: 	foreach my $indi ($ged->individuals) {
  159: 		next unless(ref($indi));
  160: 		my $name = $indi->name || 'Unknown';
  161: 		$name =~ s/\///g;	# Remove GEDCOM name delimiters
  162: 		$name =~ s/'/&apos;/g;	# Probably this is enough HTML::Entities
  163: 
  164: 		# Birth events
  165: 		if (my $birth = $indi->birth) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  166: 			if (ref($birth) && (my $place = $birth->place)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  167: 				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: 		if (my $death = $indi->death) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  178: 			if (ref($death) && (my $place = $death->place)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  179: 				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 → 190 → 213  190: 	foreach my $fam ($ged->families) {
  191: 		next unless defined($fam) && ref($fam);	# Yes, really
  192: 
  193: 		my $husband = (ref($fam->husband) && $fam->husband->name) ? $fam->husband->name : 'Unknown';
  194: 		my $wife = (ref($fam->wife) && $fam->wife->name) ? $fam->wife->name : 'Unknown';
  195: 
  196: 		$husband =~ s/\///g;
  197: 		$wife =~ s/\///g;
  198: 
  199: 		if (my $marriage = $fam->marriage) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  200: 			if (ref($marriage) && (my $place = $marriage->place)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  201: 				$husband =~ s/'/&apos;/;
  202: 				$wife =~ s/'/&apos;/;
  203: 				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 → 220 → 252  213: 	print 'Found ', scalar(@events), " events with location data.\n" if($debug);
  214: 	print "Geocoding locations...\n" if($debug);
  215: 
  216: 	# Geocode all events
  217: 	my @geocoded_events;
  218: 	my %cache;	# TODO allow use of params->{cache} if given
  219: 
  220: 	foreach my $event (@events) {
  221: 		my $place = $event->{place};
  222: 
  223: 		# Check cache
  224: 		unless (exists $cache{$place}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  225: 			my $location = $geocoder->geocode(location => $place);
  226: 			my ($lat, $long) = _coordinates($location);
  227: 
  228: 			if (defined($lat) && defined($long)) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  229: 				$cache{$place} = {
  230: 					lat => $lat,
  231: 					lon => $long,	# The cache's own key, not a key of the result
  232: 				};
  233: 				print "\tGeocoded: $place\n" if($debug);
  234: 				sleep 1 unless _is_local($location);	# Be nice to geocoding service
  235: 
  236: 			} else {
  237: 				print "\tFailed to geocode: $place\n" if($debug);
  238: 				$cache{$place} = undef;
  239: 				sleep 1;	# Be nice to geocoding service
  240: 			}
  241: 		}
  242: 
  243: 		if ($cache{$place}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  244: 			push @geocoded_events, {
  245: 				%$event,
  246: 				lat => $cache{$place}{lat},
  247: 				lon => $cache{$place}{lon},
  248: 			};
  249: 		}
  250: 	}
  251: 
●252 → 260 → 266  252: 	print 'Successfully geocoded ', scalar(@geocoded_events), " events.\n" if($debug);
  253: 
  254: 	return('', '') if(scalar(@geocoded_events) == 0);	# Empty

  Mutants (Total: 1, Killed: 1, Survived: 0)
  255: 
  256: 	print "Generating map...\n" if($debug);
  257: 
  258: 	# Group events by location
  259: 	my %location_groups;
  260: 	foreach my $event (@geocoded_events) {
  261: 		my $key = sprintf('%.6f,%.6f', $event->{lat}, $event->{lon});
  262: 		push @{$location_groups{$key}}, $event;
  263: 	}
  264: 
  265: 	# Generate map based on available API key
●266 → 267 → 273  266: 	my $map;
  267: 	if ($google_key) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  268: 		$map = _generate_google_map(\%location_groups, $height, $width, $google_key);
  269: 	} else {
  270: 		$map = _generate_osm_map(\%location_groups, $height, $width);
  271: 	}
  272: 
  273: 	return $map->onload_render();

  Mutants (Total: 2, Killed: 2, Survived: 0)
  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.
  282: sub _coordinates {
●283 → 287 → 291  283: 	my $location = shift;
  284: 
  285: 	return unless defined($location);
  286: 
  287: 	if(blessed($location) && $location->can('latitude') && $location->can('longitude')) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  288: 		return ($location->latitude(), $location->longitude());
  289: 	}
  290: 
●291 → 291 → 300  291: 	if(ref($location) eq 'HASH') {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  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: 			$location->{'long'} // $location->{'lng'} // $location->{'lon'});
  298: 	}
  299: 
  300: 	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.
  307: sub _is_local {
  308: 	my $location = shift;
  309: 
  310: 	return 0 unless ref($location);

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  311: 	return 0 if(ref($location) eq 'ARRAY');	# A flat [lat, lon] says nothing about provenance

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  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: 	return 1 if(defined($location->{'database'}) && $LOCAL_DATABASES{$location->{'database'}});

  Mutants (Total: 2, Killed: 2, Survived: 0)
  320: 	return 1 if(defined($location->{'geocoder'}) && $location->{'geocoder'} =~ /^Geo::Coder::Free/);

  Mutants (Total: 2, Killed: 2, Survived: 0)
  321: 
  322: 	return 0;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  323: }
  324: 
  325: # Generate HTML for grouped events
  326: sub _generate_popup_html {
●327 → 335 → 340  327: 	my ($events) = @_;
  328: 
  329: 	my $place = $events->[0]{place};
  330: 	my $event_count = scalar(@$events);
  331: 
  332: 	# Add scrollable container if more than 5 events
  333: 	my $container_start = '';
  334: 	my $container_end = '';
  335: 	if ($event_count > 5) {

					

					Mutants (Total: 4, Killed: 0, Survived: 4)
					

  336: 		$container_start = '<div style="max-height: 300px; overflow-y: auto;">';
  337: 		$container_end = '</div>';
  338: 	}
  339: 
●340 → 344 → 349  340: 	my $html = "<b>$place</b><br><br>$container_start";
  341: 
  342: 	# Group by type
  343: 	my %by_type;
  344: 	foreach my $event (@$events) {
  345: 		push @{$by_type{$event->{type}}}, $event;
  346: 	}
  347: 
  348: 	# Sort function for dates
●349 → 362 → 375  349: 	my $sort_by_date = sub {
  350: 		my $date_a = $a->{'date'};
  351: 		my $date_b = $b->{'date'};
  352: 
  353: 		# Put unknown dates at the end
  354: 		return 1 if $date_a =~ /^Unknown/i && $date_b !~ /^Unknown/i;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  355: 		return -1 if $date_b =~ /^Unknown/i && $date_a !~ /^Unknown/i;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  356: 		return 0 if $date_a =~ /^Unknown/i && $date_b =~ /^Unknown/i;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  357: 
  358: 		return Date::Cmp::datecmp($date_a, $date_b);

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  359: 	};
  360: 
  361: 	# Add births
  362: 	if ($by_type{birth}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  363: 		$html .= '<b>Births:</b><br>';
  364: 		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: 			);
  370: 		}
  371: 		$html .= '<br>';
  372: 	}
  373: 
  374: 	# Add marriages
●375 → 375 → 388  375: 	if ($by_type{marriage}) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

  376: 		$html .= '<b>Marriages:</b><br>';
  377: 		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: 			);
  383: 		}
  384: 		$html .= '<br>';
  385: 	}
  386: 
  387: 	# Add deaths
●388 → 388 → 399  388: 	if ($by_type{death}) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  389: 		$html .= '<b>Deaths:</b><br>';
  390: 		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: 			);
  396: 		}
  397: 	}
  398: 
  399: 	$html .= $container_end;
  400: 
  401: 	return $html;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  402: }
  403: 
  404: # Generate Google Maps
  405: sub _generate_google_map {
●[NOT COVERED] 406 → 416 → 435  406: 	my ($location_groups, $height, $width, $key) = @_;
  407: 
  408: 	my $map = HTML::GoogleMaps::V3->new(
  409: 		key => $key,
  410: 		height => $height,
  411: 		width => $width
  412: 	);
  413: 
  414: 	# Add markers for each location
  415: 	my $first = 1;
  416: 	foreach my $loc_key (keys %$location_groups) {
  417: 		my $events = $location_groups->{$loc_key};
  418: 		my ($lat, $lon) = split /,/, $loc_key;
  419: 
  420: 		my $html = _generate_popup_html($events);
  421: 
  422: 		$map->add_marker(
  423: 			point => [$lat, $lon],
  424: 			html => $html,
  425: 		);
  426: 
  427: 		# Center on first location
  428: 		if ($first) {

					

					Mutants (Total: 1, Killed: 0, Survived: 1)
					

  429: 			$map->center([$lat, $lon]);
  430: 			$map->zoom(4);
  431: 			$first = 0;
  432: 		}
  433: 	}
  434: 
  435: 	return $map;

					

					Mutants (Total: 2, Killed: 0, Survived: 2)
					

  436: }
  437: 
  438: # Generate OpenStreetMap using HTML::OSM
  439: sub _generate_osm_map {
●440 → 446 → 459  440: 	my ($location_groups, $height, $width) = @_;
  441: 
  442: 	# Create HTML::OSM object
  443: 	my $osm = HTML::OSM->new(zoom => 12, height => $height, width => $width);
  444: 
  445: 	# Add markers for each location
  446: 	foreach my $loc_key (keys %$location_groups) {
  447: 		my $events = $location_groups->{$loc_key};
  448: 		my ($lat, $lon) = split /,/, $loc_key;
  449: 
  450: 		my $html = _generate_popup_html($events);
  451: 
  452: 		$osm->add_marker(
  453: 			point => [$lat, $lon],
  454: 			html => $html,
  455: 		);
  456: 	}
  457: 
  458: 	# Find location with most events
●459 → 461 → 469  459: 	my ($center_lat, $center_lon) = (0, 0);
  460: 	my $max_events = 0;
  461: 	foreach my $loc_key (keys %$location_groups) {
  462: 		my $event_count = scalar(@{$location_groups->{$loc_key}});
  463: 		if ($event_count > $max_events) {

					

					Mutants (Total: 4, Killed: 0, Survived: 4)
					

  464: 			$max_events = $event_count;
  465: 			($center_lat, $center_lon) = split /,/, $loc_key;
  466: 		}
  467: 	}
  468: 
  469: 	$osm->center([$center_lat, $center_lon]);
  470: 
  471: 	return $osm;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  472: }
  473: 
  474: =head1 BUGS
  475: 
  476: =head1 SEE ALSO
  477: 
  478: =over 4
  479: 
  480: =item * L<Test Dashboard|https://nigelhorne.github.io/HTML-Genealogy-Map/coverage/>
  481: 
  482: =item * L<Configure an Object at Runtime|Object::Configure>
  483: 
  484: =back
  485: 
  486: =head1 REPOSITORY
  487: 
  488: L<https://github.com/nigelhorne/HTML-Genealogy-Map>
  489: 
  490: =head1 SUPPORT
  491: 
  492: This module is provided as-is without any warranty.
  493: 
  494: Please report any bugs or feature requests to C<bug-html-genealogy-map at rt.cpan.org>,
  495: or through the web interface at
  496: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=HTML-Genealogy-Map>.
  497: I will be notified, and then you'll
  498: automatically be notified of progress on your bug as I make changes.
  499: 
  500: You can find documentation for this module with the perldoc command.
  501: 
  502:     perldoc HTML::Genalogy::Map
  503: 
  504: You can also look for information at:
  505: 
  506: =over 4
  507: 
  508: =item * MetaCPAN
  509: 
  510: L<https://metacpan.org/dist/HTML-Genealogy-Map>
  511: 
  512: =item * RT: CPAN's request tracker
  513: 
  514: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=HTML-Genealogy-Map>
  515: 
  516: =item * CPAN Testers' Matrix
  517: 
  518: L<http://matrix.cpantesters.org/?dist=HTML-Genealogy-Map>
  519: 
  520: =item * CPAN Testers Dependencies
  521: 
  522: L<http://deps.cpantesters.org/?module=HTML::Genalogy::Map>
  523: 
  524: =back
  525: 
  526: =head1 AUTHOR
  527: 
  528: Nigel Horne, C<< <njh at nigelhorne.com> >>
  529: 
  530: =head1 LICENCE AND COPYRIGHT
  531: 
  532: Copyright 2025-2026 Nigel Horne.
  533: 
  534: Usage is subject to the GPL2 licence terms.
  535: If you use it,
  536: please let me know.
  537: 
  538: =cut
  539: 
  540: 1;