Some of the repetitive violations were suppressed.
295.83KiB; Perl | 2020-10-27 23:27:19+01 | Statements 6813 | SLOC 8809
1
#!/usr/bin/env perl
2
3
# Author Nigel Horne: njh@bandsman.co.uk
4
# Copyright (C) 2015-2020, Nigel Horne
5
6
# Usage is subject to licence terms.
7
# The licence terms of this software are as follows:
8
# Personal single user, single computer use: GPL2
9
# All other users (including Commercial, Charity, Educational, Government)
10
#	must apply in writing for a licence for use from Nigel Horne at the
11
#	above e-mail.
12
13
# TODO: Geo::Coder::GeocodeFarm, once github issue 1 has been fixed
14
# TODO: Investigate BGS
15
# TODO: Finish XML, perhaps use XML::Hash for display?
16
# TODO: Can I use a kdTree to determine events or residences close by each other?
17
# TODO: add male and female average lifespan to the facts
18
# TODO: finish -x option to create a blog of differences over time of
19
#	changes to the tree
20
# TODO: look at census records to note the different places that a person's children
21
#	were born and note if the residences of the person don't include those places
22
# TODO: Create occupations database
23
# TODO:	remove date_to_datetime
24
# TODO: flag if census locations are XYX and Y is more than (say) 50 miles from X
25
# TODO: timeline of each person - like or using timetoast.com
26
# TODO: investigate Locale::Geocode
27
28
# -d:	Download copies of objects rather than link to them, useful if the
29
#	objects are on pay sites such as FMP
30
31
# For the Simile Timeline format see
32
#	http://www.simile-widgets.org/wiki/Timeline_EventSources
33
# For visjs see
34
#	http://visjs.org/docs/timeline/
35
36
# dnf install langpacks-fr glibc-all-langpacks -y
37
38
use 5.020;
39
use utf8;
40
use strict;
41
use warnings;
42
# use open qw(:std :utf8);	# Do not use, it breaks printing
43
	# HTTP::Response->decoded_content() to a file
44
# no feature qw(indirect);
45
# use feature qw(signatures);
46
# no warnings qw(experimental::signatures);
47
48
no lib '.';
49
50
my @needfull;
51
52
# Install Pre-requisites
53
BEGIN {
54
	my @modules = (
55
		'Config::Auto',
56
		'File::Basename', 'File::Copy', 'File::Temp', 'File::Print::Many',
57
		'Date::Manip', 'Parse::RecDescent', 'Roman',
58
		'Gedcom', 'Genealogy::Gedcom::Date',
59
		'Date::Parse', 'Geo::Coder::List', 'Geo::Coder::Free',
60
		'IPC::System::Simple', 'Geo::Coder::Ovi', 'String::Compare',
61
		'Genealogy::Gedcom::Date',
62
		'Geo::Coder::DataScienceToolkit',
63
		# 'Geo::Coder::Free::OpenAddresses',
64
		'Geo::Coder::RandMcnally', 'Geo::Coder::US::Census',
65
		'Geo::Coder::OSM', 'Geo::Coder::XYZ', 'Geo::Coder::CA',
66
		'Geo::Coder::OpenCage', 'Geo::Coder::Google',
67
		'Geo::Coder::GooglePlaces',
68
		'Geo::Coder::Bing', 'Lingua::EN::ABC',
69
		'Geo::Parser::Text', 'GIS::Distance',
70
		'HTML::Entities', 'Image::Info', 'JSON',
71
		'List::Util',
72
		'LWP::Simple::WithCache', 'MIME::Base64',
73
		'DateTime', 'DateTime::Duration',
74
		'DateTime::Format::Genealogy', 'DateTime::Format::Natural',
75
		# 'Geo-Coder-PlaceFinder-0.1.tar.gz'
76
		'Class::Simple::Cached', 'Class::Simple::Readonly::Cached',
77
		'HTML::GoogleMaps::V3 0.13',
78
		'Sort::Key::DateTime', 'Text::Names', 'Text::Names::GB',
79
		'Term::ANSIColor',
80
		'URI', 'URI::Find::Schemeless',
81
		'Locale::AU', 'Locale::CA', 'Locale::US',
82
		'XML::Dumper', 'XML::Twig', 'CHI', 'Class::Simple',
83
		# 'Geo::StreetAddress::US',
84
		'Getopt::Std', 'Lingua::EN::NameCase', 'Lingua::EN::NameParse',
85
		'Lingua::EN::Inflect',
86
		'Locale::Object::Country',
87
		'Unicode::Diacritic::Strip', 'URI::Find::Schemeless',
88
	);
89
90
	foreach my $module(@modules) {
91
		eval "use $module";
92
		if($@) {
93
			push @needfull, $module;
94
		}
95
	}
96
	# Fix for this module not being found
97
	eval 'use Geo::Coder::PlaceFinder';
98
	if($@) {
99
		push @needfull, 'F/FR/FRIFFIN/Geo-Coder-PlaceFinder-0.1.tar.gz'
100
	}
101
	# Apparently it's "unauthorized", but there's no other module with the same name
102
103
	if(defined($ENV{'LANG'}) && ($ENV{'LANG'} =~ /^fr/)) {
104
		eval 'use Lingua::FR::Numbers::Ordinate';
105
		if($@) {
106
			push @needfull, 'N/NH/NHORNE/Lingua-FR-Numbers-Ordinate-0.03.tar.gz';
107
		}
108
	} else {
109
		eval 'use Lingua::EN::Numbers::Ordinate';
110
		if($@) {
111
			push @needfull, 'Lingua::EN::Numbers::Ordinate';
112
		}
113
	}
114
115
	if(scalar(@needfull)) {
116
		my $list = join(' ', @needfull);
117
		print "Installing $list\n";
118
		system("cpan -i $list");
119
	}
120
121
	# FIXME
122
	$SIG{__WARN__} = sub {
123
		my $warning = shift;
124
		if(($warning !~ /Subroutine Geo::Coder::OpenCage::ua redefined at/) &&
125
		   ($warning !~ /Subroutine ua redefined at/) &&
126
		   ($warning !~ /Subroutine HTML::GoogleMaps::V3::_text_to_point redefined at/) &&
127
		   ($warning !~ /Subroutine Gedcom::Individual::relationship redefined at/)) {
128
			if($warning =~ /^Use of uninitialized value/) {
129
				die $warning;
130
			}
131
			warn $warning;
132
		}
133
	};
134
}
135
136
foreach my $module(@needfull) {
137
	my $version;
138
	if($module =~ /(.+)\s(.+)$/) {
139
		$module = $1;
140
		$version = $2;
141
	}
142
	if($module =~ /.+\/(.+)/) {
143
		$module = $1;
144
	}
145
	eval "require $module";
146
	if($@) {
147
		die $@;
148
	}
149
	$module->import();
150
	# if($version && ($module::VERSION < $version)) {
151
		# die "$module: need $version got ", $module::VERSION;
152
	# }
153
}
154
155
use autodie qw(:all);
156
# use warnings::unused;
157
158
# BEGIN {
159
	# *CORE::GLOBAL::die = \&main::die;
160
# }
161
162
# use Lingua::EN::AddressParse;
163
# use Memoize;
164
use Class::Simple::Cached 0.03;
165
use Class::Simple::Readonly::Cached 0.02;
166
use POSIX;
167
168
sub get_location($);
169
170
my %opts;
171
getopts('cdfFG:g:h:J:lL:mwWvx:', \%opts);
172
173
die "Usage: $0 [ -c ] [ -d ] [ -F ] [ -f ] [ -g google-search-verification ] [ -h home-person-name ] [ -l ] [ -L max_records ] [ -m [-G Google-Maps-GeoLocation-key ] [ -J Google-Maps-JavaScript-key ] ] [ -w [ -W ] ] [ -x current_people.xml ] filename [ filename2 ]\n" unless($ARGV[0]);
174
175
use	constant	MAX_INDEX => 0;	# Debugging, set this to the number of records to print.
176
					# Set to 0 to run on the entire database
177
178
my $gedcal;
179
if(-x '/usr/bin/gedcom') {
180
	$gedcal = '/usr/bin/gedcom';
181
} elsif(-x '/usr/local/bin/gedcom') {
182
	$gedcal = '/usr/local/bin/gedcom';
183
} elsif(-x '../gedcom/gedcom') {
184
	$gedcal = '../gedcom/gedcom';
185
}
186
187
my @modules;
188
@needfull = ();
189
190
if($opts{'d'} || $opts{'m'} || $opts{'w'}) {
191
	push @modules, 'File::Spec';
192
193
	if(!$ENV{'CACHEDIR'}) {
194
		push @modules, 'File::HomeDir';
195
	}
196
197
	if($opts{'m'} || $opts{'w'}) {
198
		push @modules, 'Geo::Coder::Free::Local';
199
		if($opts{'w'}) {
200
			push @modules,
201
				'Geo::Coder::Postcodes',
202
				'LWP::UserAgent::Cached', 'Genealogy::ChroniclingAmerica', 'Locale::Country';
203
		}
204
	}
205
}
206
if($opts{'d'} || $opts{'m'}) {
207
	push @modules, 'HTTP::Cache::Transparent';
208
}
209
if($opts{'m'} || $opts{'w'}) {
210
	push @modules, 'LWP::UserAgent::Throttled', 'Geo::GeoNames';
211
}
212
if($gedcal || !$opts{'w'}) {
213
	push @modules, 'String::ProgressBar';
214
}
215
if($opts{'F'}) {
216
	push @modules, ' Image::Magick::Thumbnail';
217
}
218
if(get_language()) {
219
	push @modules, 'Locale::Country::Multilingual';
220
}
221
222
foreach my $module(@modules) {
223
	eval "require $module";
224
	if($@) {
225
		push @needfull, $module;
226
	} else {
227
		$module->import();
228
	}
229
}
230
if(scalar(@needfull)) {
231
	system('cpan -i ' . join(' ', @needfull));
232
}
233
234
foreach my $module(@modules) {
235
	my $version;
236
	if($module =~ /(.+)\s(.+)$/) {
237
		$module = $1;
238
		$version = $2;
239
	}
240
	eval "require $module";
241
	if($@) {
242
		die $@;
243
	}
244
	$module->import();
245
	# if($version && ($module::VERSION < $version)) {
246
		# die "$module: need $version got ", $module::VERSION;
247
	# }
248
}
249
250
my $me;
251
my @myancestors;
252
my @mydescendents;
253
my %printed;
254
my %places;
255
my $surnames;
256
my %censuses;
257
my %twins;
258
my %all_military;
259
my %all_occupations;
260
my %orphans;
261
my %images;
262
my %all_locations;
263
my %all_events;	# Maps events to people
264
my %all_dates;	# Maps dates to the hashref from Genealogy::Gedcom::Date
265
my %name_date;	# Maps first names to quarter century
266
my %changes;	# If the -x option is given, tracks changes between the previous run and this run
267
my $facts;
268
# my $pi = atan2(1,1) * 4;
269
270 1
binmode(STDOUT, ':utf8');
271
272
# Help OSM to match
273
my %location_mappings = (
274
	'Coventry, Warwickshire, England' => 'Coventry, England',
275
	'Minster, Sheppey, Kent' => 'Minster, Swale, Kent',
276
	'Bromley, Kent, Endland' => 'Bromley, London, England',
277
	'Croydon, Surrey, Endland' => 'Croydon, London, England',
278
	'Thornton Heath, Surrey, Endland' => 'Thornton Heath, London, England',
279
	'Edinburgh, Midlothian, Scotland' => 'Edinburgh, Scotland',
280
);
281
282
my $nameparser = Lingua::EN::NameParse->new(extended_titles => 1);
283
my $ged = Gedcom->new(gedcom_file => $ARGV[0], read_only => 1);
284
$ged = Class::Simple::Cached->new(object => $ged, cache => CHI->new(driver => 'RawMemory', datastore => {}));
285
286
my $language = get_language();
287
288
my $date_parser = Genealogy::Gedcom::Date->new();
289
my $dfn;
290
if($language eq 'French') {
291
	# $dfn = DateTime::Format::Natural->new(format => 'dd/mm/yy', lang => 'fr');	 # not supported
292
	$dfn = DateTime::Format::Natural->new(format => 'dd/mm/yy');
293
} elsif((defined($ENV{'LC_TIME'}) && ($ENV{'LC_TIME'} =~ /^en_US/)) ||
294
	((defined($ENV{'LC_ALL'}) && ($ENV{'LC_ALL'} =~ /^en_US/)))) {
295
	$dfn = DateTime::Format::Natural->new();
296
} else {
297
	$dfn = DateTime::Format::Natural->new(format => 'dd/mm/yy');
298
}
299
my $dfg = DateTime::Format::Genealogy->new();
300
my $oneday = DateTime::Duration->new(days => 1);
301
my $tenmonths = DateTime::Duration->new(months => 10);
302
my $sixteenyears = DateTime::Duration->new(years => 16);
303
my $fortyyears = DateTime::Duration->new(years => 40);
304
# my $fetcher;
305
my $year_1000 = DateTime->new(year => 1000, month => 1, day => 1);
306
307
my $lcm;
308
if($language) {
309
	$lcm = Class::Simple::Cached->new(object => Locale::Country::Multilingual->new(),
310
		cache => CHI->new(driver => 'RawMemory', datastore => {}));
311
}
312
313
my $config;
314
315
eval { $config = Config::Auto::parse() };
316
317
my %gp_args = (apiver => 3);
318
my $geolocation_key;
319
if($opts{'G'}) {
320
	$geolocation_key = $opts{'G'};
321
} elsif($ENV{'GMAP_KEY'}) {	# Compatibility with various CPAN modules
322
	$geolocation_key = $ENV{'GMAP_KEY'};
323
} elsif($config && $config->{'google_maps_geolocation_key'}) {
324
	$geolocation_key = $config->{'google_maps_gelocation_key'};
325
}
326
$gp_args{'key'} = $geolocation_key;
327
$gp_args{'api_key'} = $geolocation_key;
328
329
my $javascript_key;
330
if($opts{'J'}) {
331
	$javascript_key = $opts{'J'};
332
} elsif($config && $config->{'google_maps_javascript_key'}) {
333
	$javascript_key = $config->{'google_maps_javascript_key'};
334
}
335
336
my $geocoder;
337
my $textgeocoder;
338
my $freegeocoder;
339
340
if($opts{'m'} || $opts{'w'}) {
341
	my $l = $ENV{'LANG'};
342
	if(defined($l) && ($l =~ /^([a-z]{2})/i)) {
343
		$gp_args{'language'} = lc($1);
344
	}
345
346
	# my $geocoder = Geo::Coder::List->new(cache => CHI->new(driver => 'Memcached', servers => [ '192.168.1.15:11211', '127.0.0.1:11211' ]));
347
	my $cachedir;
348
	if(my $e = $ENV{'CACHEDIR'}) {
349
		$cachedir = File::Spec->catfile($e, basename($0));
350
	} else {
351
		# $cachedir = File::Spec->catfile(File::Spec->tmpdir(), 'cache', basename($0));
352
		$cachedir = File::Spec->catfile(File::HomeDir->my_home(), '.cache', basename($0));
353
	}
354
	$geocoder = Geo::Coder::List->new(cache => CHI->new(driver => 'File', root_dir => $cachedir));
355
	$geocoder->push(Geo::Coder::Free::Local->new());
356
357
	if(my $oa = $ENV{'OPENADDR_HOME'}) {
358
		$freegeocoder = Geo::Coder::Free->new(openaddr => $oa);
359
		# $geocoder->push({ regex => qr/,[\w\s]+,[\w\s]+$/, geocoder => $freegeocoder });
360
		# $geocoder->push({ regex => qr/,\s*(USA|US|United States|Canada|Australia)+$/, geocoder => Geo::Coder::Free::OpenAddresses->new(openaddr => $oa) })
361
			# ->push({ regex => qr/^[\w\s\-]+?,[\w\s]+,[\w\s]+?$/, geocoder => Geo::Coder::Free->new() });
362
		# US, Canada and Australia are full
363
		# Counties and towns in the UK are full
364
		$geocoder->push({ regex => qr/,\s*(USA|US|United States|Canada|Australia)\s*$/, geocoder => $freegeocoder })
365
			->push({ regex => qr/^([\w\s]+,)?\s*[\w\s]+,\s*[\w\s]+\s*$/, geocoder => $freegeocoder });
366
	} else {
367
		$freegeocoder = Geo::Coder::Free->new();
368
		$geocoder->push({ regex => qr/^[\w\s\-]+?,[\w\s]+,[\w\s]+?$/, geocoder => $freegeocoder })
369
			# E.g. 'Nebraska, USA'
370
			->push({ regex => qr/^[\w\s]+,\s*(UK|England|Canada|USA|US|United States)$/i, geocoder => $freegeocoder });
371
	}
372
	$geocoder->push({ regex => qr/^[\w\s]+,\s*[\w\s]+,\s*(UK|England|Wales|Scotland)$/i, geocoder => $freegeocoder });
373
374
	if(my $username = $ENV{'GEONAMES_USER'}) {
375
		$geocoder->push(Geo::GeoNames->new(username => $username));
376
	}
377
	if($geolocation_key) {
378
		# DST isn't that good for the UK
379
		# $geocoder->push({ regex => qr/(UK|United Kingdom|England|USA|US|United States|Wales)$/i, geocoder => Geo::Coder::DataScienceToolkit->new() })
380
		$geocoder->push({ regex => qr/^\d.+?,.+?,\s*(USA|US|United States)$/i, geocoder => Geo::Coder::US::Census->new() })
381
			->push({ limit => 100, regex => qr/(Canada|USA|US|United States)$/i, geocoder => Geo::Coder::CA->new() })
382
			->push({ regex => qr/(USA|US|United States)$/i, geocoder => Geo::Coder::RandMcnally->new() })
383
			->push(Geo::Coder::OSM->new())
384
			->push({ regex => qr/^[\w\s-]+,\s*[\w\s]+,\s*(UK|United Kingdom|England|Wales)$/i, geocoder => Geo::Coder::Postcodes->new() })
385
			->push(Geo::Coder::Ovi->new())
386
			->push({ regex => qr/(USA|US|United States)$/i, geocoder => Geo::Coder::DataScienceToolkit->new() })
387
			->push({ limit => 100, geocoder => Geo::Coder::GooglePlaces->new(%gp_args) })
388
			->push({ limit => 200, geocoder => Geo::Coder::XYZ->new()})
389
			->push(Geo::Coder::Google->new());
390
	} else {
391
		# DST isn't that good for the UK
392
		# $geocoder->push({ regex => qr/(UK|United Kingdom|England|USA|US|United States|Wales)$/i, geocoder => Geo::Coder::DataScienceToolkit->new() })
393
		$geocoder->push({ regex => qr/(USA|US|United States)$/i, geocoder => Geo::Coder::DataScienceToolkit->new() })
394
			->push({ regex => qr/^\d.+?,.+?,\s*(USA|US|United States)$/i, geocoder => Geo::Coder::US::Census->new() })
395
			->push({ limit => 100, regex => qr/(Canada|USA|US|United States)$/i, geocoder => Geo::Coder::CA->new() })
396
			->push({ regex => qr/(USA|US|United States)$/i, geocoder => Geo::Coder::RandMcnally->new() })
397
			->push({ regex => qr/^[\w\s-]+,\s*[\w\s]+,\s*(UK|United Kingdom|England|Wales)$/i, geocoder => Geo::Coder::Postcodes->new() })
398
			->push(Geo::Coder::OSM->new())
399
			# ->push({ limit => 200, geocoder => Geo::Coder::XYZ->new()})
400
			->push(Geo::Coder::Ovi->new());
401
			# ->push(Geo::Coder::Google->new())
402
			# ->push(Geo::Coder::GooglePlaces->new());
403
	}
404
	if(my $key = $ENV{'GEO_CODER_OPENCAGE_API_KEY'}) {
405
		$geocoder->push({ limit => 200, geocoder => Geo::Coder::OpenCage->new(api_key => $key) });
406
	}
407
	if(my $key = $ENV{BMAP_KEY}) {
408
		$geocoder->push(Geo::Coder::Bing->new(key => $key));
409
	}
410
411
	my $ua = LWP::UserAgent::Throttled->new(agent => basename($0), keep_alive => 1);
412
	$ua->env_proxy(1);
413
414
	# TODO: throttle other geocoders
415
	$ua->throttle({
416
		'nominatim.openstreetmap.org' => 1,
417
		'geocode.xyz' => 2,
418
		'geocoder.ca' => 1,
419
		'opencagedata.com' => 1,
420
		'api.postcodes.io' => 1,
421
		'where.desktop.mos.svc.ovi.com' => 1,
422
		'geocoding.geo.census.gov' => 1,
423
		'a2ageo.rmservers.com' => 1,
424
		'dev.virtualearth.net' => 1,	# Bing
425
		'api.geonames.org' => 1,
426
		'yboss.yahooapis.com' => 1,	# Geo::Coder::PlaceFinder
427
	});
428
429
	# G::C::GooglePlaces
430
	$ua->throttle({ 'maps.googleapis.com' => 0.1 }) unless($geolocation_key);
431
	$ua->ssl_opts(verify_hostname => 0);	# prevent "Can't connect to geocode.xyz:443 (certificate verify failed)"
432
	$geocoder->ua($ua);
433
434
	# Geo::Coder::PlaceFinder doesn't support the ua() method
435
	if((my $ckey = $ENV{'YAHOO_CONSUMER'}) && (my $skey = $ENV{'YAHOO_SECRET'})) {
436
		$geocoder->push(Geo::Coder::PlaceFinder->new(consumer_key => $ckey, secret_key => $skey, ua => $ua));
437
	}
438
439
	# $textgeocoder = Geo::Parser::Text->new('https://geocoder.ca');
440
	$textgeocoder = Geo::Parser::Text->new('https://geocode.xyz');
441
}
442
443
# FIXME: Do this properly
444
my %censusmaps = (
445
	'1841 England Census' => '1841 UK Census',
446
	'1841 England, Wales & Scotland Census - Findmypast' => '1841 UK Census',
447
	'1851 England Census' => '1851 UK Census',
448
	'1851 Wales Census' => '1851 UK Census',
449
	'1851 Census' => '1851 UK Census',
450
	'1851 England, Wales & Scotland Census - Findmypast' => '1851 UK Census',
451
	'1851 United Kingdom Census Sample' => '1851 UK Census',
452
	'1861 England Census' => '1861 UK Census',
453
	'1861 England, Wales & Scotland Census - Findmypast' => '1861 UK Census',
454
	'1871 England Census' => '1871 UK Census',
455
	'1871 England, Wales & Scotland Census - Findmypast' => '1871 UK Census',
456
	'1871 Wales Census' => '1871 UK Census',
457
	'1881 England Census' => '1881 UK Census',
458
	'1881 England, Wales & Scotland Census - Findmypast' => '1881 UK Census',
459
	'1881 Isle of Man Census' => '1881 Isle of Man Census',
460
	'1881 Wales Census' => '1881 UK Census',
461
	'1891 England Census' => '1891 UK Census',
462
	'1891 England, Wales & Scotland Census - Findmypast' => '1891 UK Census',
463
	'1891 Wales Census' => '1891 UK Census',
464
	'1901 England Census' => '1901 UK Census',
465
	'1901 Wales Census' => '1901 UK Census',
466
	'1901 England, Wales & Scotland Census - Findmypast' => '1901 UK Census',
467
	'1911 England Census' => '1911 UK Census',
468
	'1911 England Census Summary Books' => '1911 UK Census',
469
	'1911 Census for England & Wales - Findmypast' => '1911 UK Census',
470
	'1911 Wales Census' => '1911 UK Census',
471
472
	'1851 Census of Canada East, Canada West, New Brunswick, and Nova Scotia' => '1851 Canadian Census',
473
	'1861 Census of Canada' => '1861 Canadian Census',
474
	'Canada Census 1861 - Findmypast' => '1861 Canadian Census',
475
	'1871 Census of Canada' => '1871 Canadian Census',
476
	'Canada Census 1871 - Findmypast' => '1871 Canadian Census',
477
	'Kent County, New Brunswick Census, 1871: Eight Subdistricts' => '1871 Canadian Census',
478
	'1881 Census of Canada' => '1881 Canadian Census',
479
	'1881 Canada Census' => '1881 Canadian Census',
480
	'Canada Census 1881 - Findmypast' => '1881 Canadian Census',
481
	'1891 Census of Canada' => '1891 Canadian Census',
482
	'Canada Census 1891 - Findmypast' => '1891 Canadian Census',
483
	'1901 Census of Canada' => '1901 Canadian Census',
484
	'Canada Census 1901 - Findmypast' => '1901 Canadian Census',
485
	'1906 Canada Census of Manitoba, Saskatchewan, and Alberta' => '1906 Canadian Census',
486
	'Canada Census 1911 - Findmypast' => '1911 Canadian Census',
487
	'1911 Census of Canada' => '1911 Canadian Census',
488
	'1916 Canada Census of Manitoba, Saskatchewan, and Alberta' => '1916 Canadian Census',
489
	'1921 Census of Canada' => '1921 Canadian Census',
490
491
	'1850 United States Federal Census' => '1850 US Census',
492
	'US Census 1850 - Findmypast' => '1850 US Census',
493
	'Us Census 1850 - Findmypast' => '1850 US Census',	# Strange...
494
495
	'New York, State Census, 1855' => '1855 New York Census',
496
497
	'1860 United States Federal Census' => '1860 US Census',
498
	'US Census 1860 - Findmypast' => '1860 US Census',
499
	'Nebraska, State Census Collection, 1860-1885' => '1860 US Census',
500
501
	'New York, State Census, 1865' => '1865 New York Census',
502
503
	'US Census 1870 - Findmypast' => '1870 US Census',
504
	'1870 United States Federal Census' => '1870 US Census',
505
506
	'New York, State Census, 1875' => '1875 New York Census',
507
508
	'1880 United States Federal Census' => '1880 US Census',
509
	'US Census 1880 - Findmypast' => '1880 US Census',
510
	'Us Census 1880 - Findmypast' => '1880 US Census',
511
512
	'US Census 1900 - Findmypast' => '1900 US Census',
513
	'1900 United States Federal Census' => '1900 US Census',
514
515
	'New York, State Census, 1905' => '1905 New York Census',
516
517
	'1910 United States Federal Census' => '1910 US Census',
518
	'US Census 1910 - Findmypast' => '1910 US Census',
519
520
	'1920 United States Federal Census' => '1920 US Census',
521
	'US Census 1920 - Findmypast' => '1920 US Census',
522
523
	'New York, State Census, 1925' => '1925 US State Censuses',
524
	'South Dakota, State Census, 1925' => '1925 US State Censuses',
525
526
	'US Census 1930 - Findmypast' => '1930 US Census',
527
	'1930 United States Federal Census' => '1930 US Census',
528
529
	'South Dakota, State Census, 1935' => '1935 US Census',
530
531
	'US Census 1940 - Findmypast' => '1940 US Census',
532
	'1940 United States Federal Census' => '1940 US Census',
533
);
534
535
# sub realdie
536
# {
537
	# CORE::die (@_);
538
# }
539
540
# sub die {
541
	# my @arg = shift;
542
#␣
543
	# print STDERR "@arg\n" if($arg[0]);
544
#␣
545
	# my $i = 0;
546
	# while((my @call_details = (caller($i++)))) {
547
		# print STDERR $call_details[1], ':', $call_details[2], ' in function ', $call_details[3], "\n";
548
	# }
549
#␣
550
	# realdie @arg;
551
# }
552
553
# $ged->validate();
554
555
my $home = $opts{h};
556
if((!defined($home)) && defined($config)) {
557
	$home = $config->{'home'};
558
	if(ref($home) eq 'ARRAY') {
559
		$home = join(' ', @{$home});
560
	}
561
}
562
563
if($home) {
564
	$me = $ged->get_individual($home);
565
	if((!defined($me)) || !ref($me)) {
566
		die "$0: Can't find '$opts{h}' in $ARGV[0]";
567
	}
568
}
569
570
my $dot;
571
my $jpegtran;
572
my $jpegoptim;
573
if($opts{'F'}) {
574
	if(-x '/usr/bin/dot') {
575
		$dot = '/usr/bin/dot';
576
	} elsif(-x '/usr/local/bin/dot') {
577
		$dot = '/usr/local/bin/dot';
578
	} elsif(-x '/sw/bin/dot') {
579
		$dot = '/sw/bin/dot';
580
	}
581
582
	if(!defined($dot)) {
583
		complain(warning => 'Graphviz not found, no family trees');
584
	} else {
585
		print "Using $dot\n" if($opts{'v'});
586
	}
587
}
588
589
for my $dir('dynamic-site/databases', 'dynamic-site/img', 'static-site') {
590
	if(-d $dir) {
591
		File::Path::rmtree($dir);
592
	}
593
}
594
595
my @dirlist = ('static-site', 'dynamic-site/databases');
596
if($dot || $opts{'d'}) {
597
	push @dirlist, 'static-site/img';
598
	push @dirlist, 'dynamic-site/img';
599
	push @dirlist, 'thumbs';
600
601
	if(-x '/usr/bin/jpegtran') {
602
		$jpegtran = '/usr/bin/jpegtran';
603
	} elsif(-x '/usr/local/bin/jpegtran') {
604
		$jpegtran = '/usr/local/bin/jpegtran';
605
	} elsif(-x '/opt/local/bin/jpegtran') {
606
		$jpegtran = '/opt/local/bin/jpegtran';
607
	} elsif(-x '/sw/bin/jpegtran') {
608
		$jpegtran = '/sw/bin/jpegtran';
609
	}
610
	if(-x '/usr/bin/jpegoptim') {
611
		$jpegoptim = '/usr/bin/jpegoptim';
612
	} elsif(-x '/usr/local/bin/jpegoptim') {
613
		$jpegoptim = '/usr/local/bin/jpegoptim';
614
	} elsif(-x '/sw/bin/jpegoptim') {
615
		$jpegoptim = '/sw/bin/jpegoptim';
616
	}
617
}
618
619
if($gedcal) {
620
	push @dirlist, 'static-site/calendar';
621
}
622
623
foreach my $dir(@dirlist) {
624
	mkdir $dir if(!-d $dir);
625
}
626
627
my $browser;
628
my $cached_browser;
629
630
if($opts{'d'} || $opts{'m'}) {
631
	$browser = LWP::UserAgent->new();
632
	$browser->env_proxy(1);
633
634
	my $cachedir = $ENV{'CACHEDIR'};
635
	if($cachedir) {
636
		mkdir $cachedir if(!-d $cachedir);
637
		$cachedir = File::Spec->catfile($cachedir, 'http-cache-transparent');
638
	} else {
639
		# $cachedir = File::Spec->catfile(File::Spec->tmpdir(), 'cache', 'http-cache-transparent');
640
		$cachedir = File::Spec->catfile(File::HomeDir->my_home(), '.cache', 'http-cache-transparent');
641
	}
642
643
	if(!-d $cachedir) {
644
		mkdir $cachedir || die "$cachedir: $!";
645
	}
646
	HTTP::Cache::Transparent::init({
647
		BasePath => $cachedir,
648
		Verbose => $opts{'v'} ? 1 : 0,
649
		NoUpdate => 24 * 60 * 60,
650
	});
651
}
652
653
# my @everyone = $ged->individuals();
654
my @everyone = map { Class::Simple::Readonly::Cached->new({ object => $_, cache => {} }) } $ged->individuals();
655
my $total = scalar(@everyone);
656
if($total == 0) {
657
	die "$0: gedcom file is empty";
658
}
659
my $index = 0;
660
661
my $pr;
662
my $au = Locale::AU->new();
663
my $ca_en = Locale::CA->new(lang => 'en');
664
my $ca_fr = Locale::CA->new(lang => 'fr');
665
my $us = Locale::US->new();
666
my $dtl = DateTime::Locale->load($ENV{'LC_TIME'} // $ENV{'LC_ALL'} // $ENV{'LANG'});
667
668
if($opts{'w'}) {
669
	my $cachedir;
670
	if(my $e = $ENV{'CACHEDIR'}) {
671
		$cachedir = File::Spec->catfile($e, 'lwp');
672
	} else {
673
		# $cachedir = File::Spec->catfile(File::Spec->tmpdir(), 'cache', 'lwp');
674
		$cachedir = File::Spec->catfile(File::HomeDir->my_home(), '.cache', 'lwp');
675
	}
676
	if(!-d $cachedir) {
677
		mkdir $cachedir || die "$cachedir: $!";
678
	}
679
	$cached_browser = LWP::UserAgent::Cached->new(cache_dir => $cachedir,
680
		agent => basename($0),
681
		keep_alive => 1
682
	);
683
	$cached_browser->env_proxy(1);
684
685
	if(!defined($ENV{'CLICOLOR'})) {
686
		$opts{'W'} = 1;
687
	}
688
} else {
689
	$pr = String::ProgressBar->new(max => $total, length => 60);
690
}
691
692
my $key = delete $opts{'g'};	# Ensure it's not stored in the XML file
693
694
my $current_people = delete $opts{'x'};
695
if($current_people) {
696
	# Creating a changelog only works if the many of the options are the same
697
	my $xml = XML::Twig->new();
698
	$xml->parsefile($current_people);
699
	my %prev_opts;
700
	foreach my $key($xml->root()->first_child('opts')->first_child('hashref')->children()) {
701
		if($key->name() eq 'item') {
702
			$prev_opts{$key->{'att'}->{'key'}} = $key->first_child()->pcdata();
703
		}
704
	}
705
	my $ok = 1;
706
	for my $opt('c', 'd', 'h') {
707
		if(defined($opts{$opt}) ne defined($prev_opts{$opt})) {
708
			$ok = 0;
709
			last;
710
		}
711
		if(defined($opts{$opt}) && ($opts{$opt} ne $prev_opts{$opt})) {
712
			$ok = 0;
713
			last;
714
		}
715
	}
716
	if(!$ok) {
717
		die "Runtime options aren't the same as given in $current_people\n";
718
	}
719
	$current_people = $xml;
720
}
721
722
open(my $xml, '>', 'dynamic-site/databases/people.xml');
723
print $xml "<?xml version=\"1.0\" encoding=\"US-ASCII\"?>\n<table>\n";
724
my $string = XML::Dumper->new()->pl2xml(\%opts);
725
$string =~ s/perldata/opts/g;
726
print $xml "\t$string";
727
########
728
# print $xml "\n</table>\n"; exit;
729
########
730
open(my $csv, '>', 'dynamic-site/databases/people.csv');
731
print $csv "entry!title!home!alive!bio!father!mother!children!citations!notes!media!family_tree!map_head!map_body!dob!dod!profile_thumbnail!marriages!sex!birth_coords!death_coords!birth_country!death_country!warnings\n";
732
733
open(my $timeline_xml, '>', 'dynamic-site/timeline.xml');
734
print $timeline_xml "<?xml version=\"1.0\"?>\n",
735
	"<data date-time-format=\"iso8601\">\n";
736
737
open(my $visjs, '>', 'dynamic-site/visjs.html');
738
print $visjs <<'HEADER';
739
<!DOCTYPE HTML>
740
<html lang="en" dir="ltr">
741
<head>
742
	<meta charset="utf8">
743
	<meta http-equiv="x-ua-compatible" content="ie=edge">
744
	<meta name="description" content="Blood relatives timeline - A ged2site webpage">
745
	<title>Blood Relatives' Timeline</title>
746
747
	<link rel="stylesheet" href="/css/web.css" type="text/css" media="screen">
748
  <style type="text/css">
749
    body, html {
750
	font-family: sans-serif;
751
	font-size: 10px;
752
    }
753
  </style>
754
755
  <script async type="text/javascript" src="https://ajax.googleapis.com/ajax/libs/jquery/3.1.1/jquery.min.js"></script>
756
  <script src="https://cdnjs.cloudflare.com/ajax/libs/vis/4.19.1/vis.min.js"></script>
757
  <link async href="https://cdnjs.cloudflare.com/ajax/libs/vis/4.19.1/vis.min.css" rel="stylesheet" type="text/css" />
758
  <style type="text/css">
759
	/* Limit the width of the biography box */
760
	/*div.vis-tooltip { font-size:10px; white-space: normal; width: 30em; word-wrap: break-word; }*/
761
	div.vis-tooltip {
762
		font-size: 10px;
763
		white-space: normal;
764
		width: 30em;
765
		max-width: 300px;
766
		word-wrap: break-word;
767
		padding: 5px;
768
	}
769
  </style>
770
</head>
771
<body>
772
	<h1>Blood Relatives' Timeline</h1>
773
	<p><font size=+1>
774
		Click and move the mouse to move around the timeline.
775
		Only people with known birth dates are shown.
776
	</font></p>
777
778
	<div id="visualization">
779
	    <div class="menu">
780
		<input type="button" id="zoomIn" value="Zoom In"/>
781
		<input type="button" id="zoomOut" value="Zoom Out"/>
782
		<input type="button" id="moveLeft" value="Scroll Left"/>
783
		<input type="button" id="moveRight" value="Scroll Right"/>
784
	    </div>
785
	</div>
786
787
<script type="text/javascript">
788
  // DOM element where the Timeline will be attached
789
  var container = document.getElementById('visualization');
790
791
  // Create a DataSet (allows two way data-binding)
792
	var items = new vis.DataSet([
793
HEADER
794
795
# TODO: Add a -p option to do something like this - it's useful in debugging
796
# foreach my $person($ged->get_individual('Dolly Cowell')) {
797
# foreach my $person($ged->get_individual('Ruth Marie Bixler')) {
798
799
foreach my $person(@everyone) {
800
	$index++;
801
	if(!$opts{'w'}) {
802
		$| = 1;
803
		$pr->update($index);
804
		$pr->write();
805
		$| = 0;
806
	}
807
	if(!$printed{$person->xref()}) {
808
		# FIXME: change &eacute; to e
809
		print $xml "\n\t<person person_id=\"$index\">";
810
		print_person({ person => $person });
811
		print $xml "\n\t</person>";
812
		print $csv "\n";
813
814
		dump_geocoder_log();
815
	}
816
	last if($opts{'L'} && ($index == $opts{'L'}));
817
	last if(MAX_INDEX && ($index >= MAX_INDEX));
818
}
819
print $xml "\n</table>\n";
820
close $xml;
821
close $csv;
822
823
print $timeline_xml "</data>\n";
824
close $timeline_xml;
825
826
print $visjs <<'FOOTER';
827
	]);
828
829
  // Configuration for the Timeline
830
  // var options = { zoomable: false, horizontalScroll: true, verticalScroll: true, autoResize: true, height: '500px', min: '1500', max: '2017' };
831
  var timelineHeight = Math.round($(window).height() * 0.85) + 'px';
832
var options = {
833
    zoomKey: 'ctrlKey',
834
    verticalScroll: true,
835
    min: '1500',
836
    max: '2017',
837
    height: timelineHeight
838
};
839
840
  // Create a Timeline
841
  var timeline = new vis.Timeline(container, items, options);
842
843
    /**
844
     * Move the timeline a given percentage to left or right
845
     * @param {Number} percentage   For example 0.1 (left) or -0.1 (right)
846
     */
847
    function move (percentage) {
848
	var range = timeline.getWindow();
849
	var interval = range.end - range.start;
850
851
	timeline.setWindow({
852
	    start: range.start.valueOf() - interval * percentage,
853
	    end:   range.end.valueOf()   - interval * percentage
854
	});
855
    }
856
857
    // attach events to the navigation buttons
858
    document.getElementById('zoomIn').onclick   = function () { timeline.zoomIn( 0.2); };
859
    document.getElementById('zoomOut').onclick  = function () { timeline.zoomOut( 0.2); };
860
    document.getElementById('moveLeft').onclick = function () { move( 0.2); };
861
	document.getElementById('moveRight').onclick = function () { move(-0.2); };
862
</script>
863
</body>
864
</html>
865
FOOTER
866
867
close $visjs;
868
869
if(!$opts{'w'}) {
870
	print "\n$index records processed\n";
871
}
872
873
my $name;
874
if($me) {
875
	$name = 'of ' . $me->as_string(nee => 1);
876
} else {
877
	$name = 'on this site';
878
}
879
880
if(scalar(%censuses)) {
881
	print "Creating census index\n";
882
	open(my $html, '>', 'static-site/censuses.html');
883
	print $html "<html><head><title>Censuses in the Family Tree $name</title>",
884
		"</head><body><center><h1>Censuses in the Family Tree $name</h1></center><br><ul>";
885
886
	open($csv, '>', 'dynamic-site/databases/censuses.psv');
887
	print $csv "entry|census|person\n";
888
889
	$index = 1;
890
	foreach my $census(sort keys(%censuses)) {
891
		my $filename = $census;
892
		$filename =~ tr/ /_/;
893
		print $html "<li><a href=\"$filename.html\">$census</a></li>";
894
895
		open(my $chtml, '>', "static-site/$filename.html");
896
		print $chtml "<html><head><title>The Family Tree $name - $census</title>",
897
			'</head>',
898
			"<body><center><h1>The Family Tree $name - $census</h1>";
899
		if($me) {
900
			print $chtml '[ <a href="', make_filename_from_person(person => $me), '">Home</a> ]';
901
		}
902
		print $chtml ' | [ <a href="surnames.html">Surnames Index</a> ]';
903
		if($opts{'w'}) {
904
			print $chtml ' | [ <a href="todo.html">Errors</a> ]';
905
		}
906
		if($gedcal) {
907
			print $chtml ' | [ <a href="calendar/index.html">Calendar</a> ]';
908
		}
909
		print $chtml ' | [ <a href="censuses.html">Census Index</a> ]',
910
			' | [ <a href="history.html">Family History</a> ]</center><br>',
911
			'<ul>';
912
913
		foreach my $name(sort keys %{$censuses{$census}}) {
914
			print $chtml '<li>',
915
				'<a href="', make_filename_from_person(person => $censuses{$census}->{$name}), '">',
916
				$name,
917
				'</a></li>';
918
			print $csv "$index|\"$census\"|\"", $censuses{$census}->{$name}->xref(), "\"\n";
919
			$index++;
920
		}
921
922
		print $chtml '</ul></body></html>';
923
		close $chtml;
924
	}
925
	print $html '</ul></body></html>';
926
	close $html;
927
	close $csv;
928
929
	undef %censuses;
930
}
931
932
if(scalar(%all_locations)) {
933
	print "Creating locations database\n";
934
935
	open($csv, '>', 'dynamic-site/databases/locations.csv');
936
	print $csv "entry!location!person!year!date\n";
937
938
	$index = 1;
939
940
	open(my $locations_xml, '>', 'dynamic-site/databases/locations.xml');
941
	print $locations_xml "<locations>\n\t<maps>\n";
942
	my ($head, $body);
943
	foreach my $year(sort keys(%all_locations)) {
944
		my %markers;
945
		foreach my $l(@{$all_locations{$year}}) {
946
			my $place = place(record => $l->{'residence'}, nopreposition => 1);
947
			$place =~ s/^\s*//;
948
			push @{$markers{$place}}, $l;
949
			print $csv "$index!$place!",
950
				$l->{'person'}->as_string({ middle_names => 1, include_years => 1 }), '!',
951
				"$year!",
952
				$l->{'date'}, "\n";
953
			$index++;
954
		}
955
956
		# Create a map of where everyone lived in each year
957
		my %args = (geocoder => $geocoder);
958
		if($javascript_key) {
959
			$args{'api_key'} = $javascript_key;
960
		}
961
		my $map = HTML::GoogleMaps::V3->new(%args);
962
		foreach my $place(keys %markers) {
963
			my @annotations = @{$markers{$place}};
964
			my $html;
965
			my $previous_date;
966
			foreach my $annotation(@annotations) {
967
				my $date = $annotation->{'date'};
968
				my $person = $annotation->{'person'};
969
				if($previous_date && ($date eq $previous_date)) {
970 1
					if($html) {
971
						$html .= ', ';
972
					}
973
				} else {
974 1
					if($html) {
975
						$html .= '<br>';
976
					}
977
					$html .= "$date: ";
978
					$previous_date = $date;
979
				}
980
				$html .= '<a href="?page=people&amp;entry=' . $person->xref() . '">' . $person->as_string() . '</a>';
981
			}
982
			add_marker(map => $map, place => HTML::Entities::decode($place), annotation => $html);
983
		}
984
		($head, $body) = $map->onload_render();
985
		$head =~ s/\n\n*/\n/g;
986
		$head =~ s/http:/https:/;
987
		$head =~ s/</&lt;/g;
988
		$head =~ s/>/&gt;/g;
989
		print $locations_xml "\t\t<map>\n\t\t\t<year>$year</year>\n\t\t\t<head>$head\n\t\t\t</head>\n\t\t</map>\n";
990
	}
991
	close $csv;
992
993
	$body =~ s/</&lt;/g;
994
	$body =~ s/>/&gt;/g;
995
	print $locations_xml "\t</maps>\n\t<body>$body</body>\n</locations>\n";
996
	close $locations_xml;
997
998
	undef %all_locations;
999
}
1000
1001
if(scalar(%all_military)) {
1002
	print "Creating military records\n";
1003
	open($csv, '>', 'dynamic-site/databases/military.csv');
1004
	print $csv "entry!person!date!place!notes\n";
1005
1006
	$index = 1;
1007
	foreach my $xref(sort keys(%all_military)) {
1008
		foreach my $entry(@{$all_military{$xref}}) {
1009
			print $csv "$index!$xref!", $entry->{'date'} || '', '!', $entry->{'place'} || '', '!', $entry->{'notes'} || '', "\n";
1010
			$index++;
1011
		}
1012
	}
1013
	close $csv;
1014
1015
	undef %all_military;
1016
}
1017
1018
if(scalar(%all_occupations)) {
1019
	print "Creating occupations records\n";
1020
	open($csv, '>', 'dynamic-site/databases/occupations.csv');
1021
	print $csv "entry!people\n";
1022
1023
	foreach my $occupation(sort keys(%all_occupations)) {
1024
		print $csv "$occupation!",
1025
			join(',', @{$all_occupations{$occupation}}),
1026
			"\n";
1027
	}
1028
	close $csv;
1029
1030
	undef %all_occupations;
1031
}
1032
1033
if(scalar(%orphans)) {
1034
	print "Creating orphan records\n";
1035
	open($csv, '>', 'dynamic-site/databases/orphans.csv');
1036
	print $csv "entry!people\n";
1037
1038
	foreach my $year(sort keys(%orphans)) {
1039
		print $csv "$year!",
1040
			join(',', @{$orphans{$year}}),
1041
			"\n";
1042
	}
1043
	close $csv;
1044
1045
	undef %orphans;
1046
}
1047
1048
if(scalar(%changes)) {
1049
	print "Adding to change blog\n";
1050
1051
	# Keep a copy in the current directory so that it's not trashed
1052
	# when the databases directory is cleared
1053
1054
	open(my $log, '>>', 'changes.psv');
1055
1056
	my $date = DateTime->now(time_zone => 'local')->ymd('');
1057
	while(my $person = shift(@{$changes{'added_people'}})) {
1058
		print $log "$date|\"",
1059
			$person->xref(),
1060
			"\"|\"Added new person\"\n";
1061
	}
1062
	while(my $change = shift(@{$changes{'changes'}})) {
1063
		print $log "$date|\"",
1064
			$change->person()->xref(),
1065
			'"|"',
1066
			$change->change(),
1067
			"\"\n";
1068
	}
1069
1070
	close($log);
1071
	copy('changes.psv', 'dynamic-site/databases/changes.psv');
1072
}
1073
1074
if(scalar(%twins)) {
1075
	print "Creating twins index\n";
1076
1077
	open($csv, '>', 'dynamic-site/databases/twins.csv');
1078
	print $csv "entry!twin\n";
1079
1080
	foreach my $twin(sort keys(%twins)) {
1081
		print $csv "$twin!$twins{$twin}\n";
1082
	}
1083
	close $csv;
1084
}
1085
1086
print "Creating surname index\n";
1087
open(my $html, '>', 'static-site/surnames.html');
1088
print $html "<html><head><title>Surnames in the Family Tree $name</title>",
1089
	"</head><body><center><h1>Surnames in the Family Tree $name</h1>";
1090
if($me) {
1091
	print $html '[ <a href="', make_filename_from_person(person => $me), '">Home</a> ]';
1092
}
1093
print $html ' | [ <a href="surnames.html">Surnames Index</a> ]',
1094
	' | [ <a href="censuses.html">Census Index</a> ]',
1095
	' | [ <a href="calendar/index.html">Calendar</a> ]';
1096
if($opts{'w'}) {
1097
	print $html ' | [ <a href="todo.html">Errors</a> ]';
1098
}
1099
print $html ' | [ <a href="history.html">Family History</a> ]</center><br><ul>';
1100
1101
open($csv, '>', 'dynamic-site/databases/surnames.csv');
1102
print $csv "entry!surname!person\n";
1103
$index = 1;
1104
1105
foreach my $surname(sort keys %{$surnames}) {
1106
	my $filename = $surname;
1107
	if($filename eq '') {
1108
		$filename = 'UNKNOWN';
1109
	}
1110
	print $html "<li><a href=\"$filename.html\">$filename</a> (";
1111
	# FIXME: "Implicit scalar context for hash in null operation"
1112
	my $count = scalar(keys %{$surnames->{$surname}});
1113
	if($count == 1) {
1114
		print $html '1 person';
1115
	} else {
1116
		print $html "$count people";
1117
	}
1118
	print $html ')</li>';
1119
1120
	open(my $shtml, '>', "static-site/$filename.html");
1121
	print $shtml "<html><head><title>The Family Tree $name - $surname</title>",
1122
		'</head>',
1123
		"<body><center><h1>The Family Tree $name - $surname</h1>";
1124
	if($me) {
1125
		print $shtml '[ <a href="', make_filename_from_person(person => $me), '">Home</a> ]';
1126
	}
1127
	if($gedcal) {
1128
		print $shtml ' | [ <a href="calendar/index.html">Calendar</a> ]';
1129
	}
1130
	print $shtml ' | [ <a href="surnames.html">Surnames Index</a> ]',
1131
		' | [ <a href="history.html">Family History</a> ]';
1132
	if($opts{'w'}) {
1133
		print $shtml ' | [ <a href="todo.html">Errors</a> ]';
1134
	}
1135
	print $shtml ' | [ <a href="censuses.html">Census Index</a> ]</center><br>',
1136
		'<ul>';
1137
1138
	foreach my $person(sort keys %{$surnames->{$surname}}) {
1139
		# print "\t$person maps to ", $surnames->{$surname}->{$person}, "\n";
1140
		print $shtml '<li>',
1141
			'<a href="', make_filename_from_person(person => $surnames->{$surname}->{$person}), "\">$person</a>",
1142
			'</li>';
1143
		print $csv "$index!$filename!", $surnames->{$surname}->{$person}->xref(), "\n";
1144
		$index++;
1145
	}
1146
1147
	print $shtml '</ul></body></html>';
1148
	close $shtml;
1149
}
1150
1151
close $csv;
1152
print $html '</ul></body></html>';
1153
close $html;
1154
1155
undef $surnames;
1156
1157
if((!defined($key)) && defined($config)) {
1158
	$key = $config->{'google_verification'};
1159
}
1160
if($key) {
1161
	open($html, '>', "static-site/$key.html");
1162
	print $html "google-site-verification: $key.html";
1163
	close $html;
1164
	if(-r "dynamic-site/$key.html") {
1165
		unlink "dynamic-site/$key.html";
1166
	}
1167
	if($^O eq 'MSWin32') {
1168
		copy("static-site/$key.html", "dynamic-site/$key.html");
1169
	} else {
1170
		link "static-site/$key.html", "dynamic-site/$key.html";
1171
	}
1172
}
1173
1174
if(open($csv, '>', 'dynamic-site/databases/names.csv')) {
1175
	# Ready for HTML::TagCloud
1176
	print $csv "entry!name!count!sex!people\n";
1177
	$index = 1;
1178
1179
	foreach my $date(sort keys %name_date) {
1180
		foreach my $firstname(sort keys %{$name_date{$date}}) {
1181
			my $count = scalar(@{$name_date{$date}{$firstname}});
1182
			my $sex = Text::Names::guessGender($firstname) || Text::Names::GB::guessGender($firstname) || '?';
1183
			my $people = join('--', @{$name_date{$date}{$firstname}});
1184
			print $csv "$date!$firstname!$count!$sex!$people\n";
1185
		}
1186
	}
1187
	close $csv;
1188
}
1189
1190
# Output the warnings last, so that all are included
1191
if($opts{'w'}) {
1192
	open(my $html, '>', 'static-site/todo.html');
1193
	print $html "<html><head><title>Errors in the Family Tree $name</title>",
1194
		"</head><body><center><h1>Errors in the Family Tree $name</h1>";
1195
	if($me) {
1196
		print $html '[ <a href="', make_filename_from_person(person => $me), '">Home</a> ]';
1197
	}
1198
	print $html ' | [ <a href="surnames.html">Surnames Index</a> ]',
1199
		' | [ <a href="censuses.html">Census Index</a> ]',
1200
		' | [ <a href="calendar/index.html">Calendar</a> ]',
1201
		' | [ <a href="history.html">Family History</a> ]</center><br>';
1202
1203
	open(my $csv, '>', 'dynamic-site/databases/todo.csv');
1204
	print $csv "entry!person!title!summary!error\n";
1205
	my $index = 1;
1206
1207
	foreach my $person(@everyone) {
1208
		if($person->{'warnings'}) {
1209
			print $html '<h2>',
1210
				'<a href="', make_filename_from_person(person => $person), '">', $person->as_string(include_years => 1), '</a></h2>',
1211
				map { HTML::Entities::encode($_) . '<br>' } @{$person->{'warnings'}};
1212
			my %seen_warnings;
1213
			foreach my $warning(@{$person->{'warnings'}}) {
1214
				next if($seen_warnings{$warning});
1215
				my $summary;
1216
				if($warning =~ /^\[\d+\]: no citation title/) {
1217
					$summary = 'Citation Title Missing';
1218
				} elsif($warning =~ /^(.+) date .+ has no citations/) {
1219
					$summary = "$1 date without citation";
1220
				} elsif($warning =~ /^(.+) place .+ has no citations/) {
1221
					$summary = "$1 place without citation";
1222
				} elsif($warning =~ /^Residence record for .+ contains no citation$/) {
1223
					$summary = 'Residence Without Citation';
1224
				} elsif($warning =~ /^Contains a residence .+ without a date/) {
1225
					$summary = 'Residence Without a Date';
1226
				} elsif($warning =~ /.+in notes is not found$/) {
1227
					$summary = 'URL in notes not found';
1228
				} elsif($warning =~ /^Unhandled event type:/) {
1229
					$summary = 'Unhandled Event Type';
1230
				} elsif($warning =~ /^Census information missing between /) {
1231
					$summary = 'Missing Census';
1232
				} elsif($warning eq '1939 UK register information missing') {
1233
					$summary = 'Missing Census';
1234
				} elsif($warning =~ /^Check the gender of the record/) {
1235
					$summary = 'Possibly Wrong Gender';
1236
				} elsif($warning =~ /^Two residence records for/) {
1237
					$summary = 'Residence Records for the Same Date that Don\'t Match';
1238
				} elsif($warning =~ /^Year of baptism .+ is before the year of birth /) {
1239
					$summary = 'Baptism Before Birth';
1240
				} elsif($warning =~ /^Year of residence .+ is after the year of death /) {
1241
					$summary = 'Residence After Death';
1242
				} elsif($warning =~ /^Born less than 10 months before sibling /) {
1243
					$summary = 'Born Under 10 Months Before Sibling';
1244
				} elsif($warning =~ /^married when less than 16 years old/) {
1245
					$summary = 'Under Age 16 When Married';
1246
				} elsif($warning =~ /^unknown sex/) {
1247
					$summary = 'Sex Not Specified';
1248
				} elsif($warning =~ /^married, but no husband relationship/) {
1249
					$summary = 'Husband Relationship Missing';
1250
				} elsif($warning =~ /^Departure record without destination/) {
1251
					$summary = 'Departure Without Destination';
1252
				} elsif($warning =~ /^Census information not used to approximate a date of birth/) {
1253
					$summary = 'Date of Birth not Calculated';
1254
				} elsif($warning =~ /^Census information not used to determine a parent/) {
1255
					$summary = 'Parent not Determined from Census';
1256
				} elsif($warning =~ /^Baptism information not used to determine a parent/) {
1257
					$summary = 'Parent not Determined from Baptism';
1258
				} elsif($warning =~ /^Unknown state in/) {
1259
					$summary = 'Unknown US State';
1260
				} elsif($warning =~ /^Residence information in/) {
1261
					$summary = 'Child\'s Location is Known but Parent\'s is not';
1262
				} elsif($warning =~ /^Unknown birth location/) {
1263
					$summary = 'Birth location not found';
1264
				} elsif($warning =~ /^Unknown death location/) {
1265
					$summary = 'Death location not found';
1266
				} elsif($warning =~ /\sisn't found$/) {
1267
					$summary = 'Location not found';
1268
				} elsif($warning =~ /^Something is wrong with the date /) {
1269
					$summary = 'Inconsistent date';
1270
				} elsif($warning =~ /^born before parent was born/) {
1271
					$summary = 'Born before Parent was born';
1272
				} elsif($warning =~ /^Date of residence .+ is after date of death/) {
1273
					$summary = 'Date of Residence After Date of Death';
1274
				} elsif($warning =~ /^Location for the event /) {
1275
					$summary = 'Location is empty';
1276
				} elsif($warning =~ /^Parent .+ is listed in the residence for .+ but this child is not/) {
1277
					$summary = 'Parent\'s Location is Known but Child\'s is not';
1278
				} elsif($warning =~ /^The census for year \d{4} has been cited,/) {
1279
					$summary = 'Census exists but no residence added';
1280
				} elsif($warning =~ /^Residence record for .+ contains no location/) {
1281
					$summary = 'Residence Record Missing Location';
1282
				} elsif($warning =~ /^Census for \d{4} after year of death/) {
1283
					$summary = 'Census after death';
1284
				} elsif($warning =~ /not living at same address as spouse/) {
1285
					$summary = 'Spouses not at same address';
1286
				} elsif($warning =~ /listed in the residence for .+, but spouse.+is not/i) {
1287
					$summary = 'Spouse location is missing';
1288
				} elsif($warning =~ /residence is very close probably should be recorded as the same address/i) {
1289
					$summary = 'Possible address errors';
1290
				} elsif($warning =~ /residence is same location probably should be recorded as the same address/i) {
1291
					$summary = 'Possible address errors';
1292
				} elsif($warning =~ /^http.+ not found$/) {
1293
					$summary = 'Website in notes is not found';
1294
				} elsif($warning =~ /^Duplicate residence on /) {
1295
					$summary = 'Duplicate Residence';
1296
				} elsif($warning =~ /^Changing 'United States' to 'USA' in /) {
1297
					$summary = 'Change &quot;United States&quot; to &quot;USA&quot;';
1298
				} elsif($warning =~ /Location for .+ differs from /) {
1299
					$summary = 'Inconsistent location';
1300
				} elsif($warning =~ /Date of residence \(.+\sdiffers from\s/i) {
1301
					$summary = 'Date of Residence Differs From Parent\'s';
1302
				} elsif($warning =~ /^Country not included in country,/) {
1303
					$summary = 'Country missing or misspelt';
1304
				} elsif($warning =~ /^Can't parse the name - assuming first name:  /) {
1305
					$summary = "Can't parse the name";
1306
				} elsif($warning =~ /^Check out https?:\/\/chroniclingamerica.loc.gov/) {
1307
					# FIXME: Lots of false positives
1308
					next;
1309
				} elsif($warning =~ /^Missing house number /) {
1310
					$summary = 'Missing house number';
1311
				} else {
1312
					$summary = $warning;
1313
				}
1314
				print $csv "$index!",
1315
					$person->xref(), '!',
1316
					$person->as_string(include_years => 1),
1317
					"!$summary!",
1318
					HTML::Entities::encode($warning),
1319
					"\n";
1320
				$seen_warnings{$warning} = $index;
1321
				$index++;
1322
			}
1323
		}
1324
	}
1325
	close $csv;
1326
	close $html;
1327
}
1328
1329
$ged = undef;
1330
1331
if($gedcal) {
1332
	print "Creating calendar\n";
1333
	if(open(my $fout, '>', 'static-site/calendar/index.html')) {
1334
		print $fout "<html><head><title>Genealogy Calendar $name</title></head>",
1335
			"<body><center><h1>Genealogy Calendar $name</h1>";
1336
		if($me) {
1337
			print $fout '[ <a href="../', make_filename_from_person(person => $me), '">Home</a> ]';
1338
		}
1339
		print $fout ' | [ <a href="../surnames.html">Surnames Index</a> ]',
1340
			' | [ <a href="../censuses.html">Census Index</a> ]';
1341
		if($opts{'w'}) {
1342
			print $fout ' | [ <a href="todo.html">Errors</a> ]';
1343
		}
1344
		print $fout ' | [ <a href="../history.html">Family History</a> ]</center><br><ul>';
1345
		my $pr = String::ProgressBar->new(max => 12, length => 60);
1346
		foreach my $month(1..12) {
1347
			if(open(my $fin, '-|', "$gedcal -dHLm $month '$ARGV[0]'")) {
1348
				$| = 1;
1349
				$pr->update($month);
1350
				$pr->write();
1351
				$| = 0;
1352
				print $fout "<li><a href=\"$month.html\">", @{$dtl->month_format_wide()}[$month - 1], '</a></li>';
1353
				open(my $mout, '>', "static-site/calendar/$month.html");
1354
				while(<$fin>) {
1355
					print $mout $_;
1356
				}
1357
				close $fin;
1358
			}
1359
		}
1360
		print "\n";
1361
		print $fout '</ul></body></html>';
1362
	}
1363
}
1364
1365
if(open(my $fout, '>', 'static-site/history.html')) {
1366
	print "Creating family history page\n";
1367
	print $fout "<html><head><title>Family History $name</title></head>",
1368
		"<body><center><h1>Family History $name</h1>";
1369
	if($me) {
1370
		print $fout '[ <a href="', make_filename_from_person(person => $me), '">Home</a> ]';
1371
	}
1372
	print $fout ' | [ <a href="surnames.html">Surnames Index</a> ]',
1373
		' | [ <a href="censuses.html">Census Index</a> ]';
1374
	if($opts{'w'}) {
1375
		print $fout ' | [ <a href="todo.html">Errors</a> ]';
1376
	}
1377
	print $fout ' | [ <a href="calendar/index.html">Calendar</a> ]</center><br>',
1378
		'<ul>';
1379
	my @sorted_events = Sort::Key::DateTime::dtkeysort { $all_events{$_}->{'date'} } keys %all_events;
1380
	my $year;
1381
	open(my $csv, '>', 'dynamic-site/databases/history.csv');
1382
	print $csv "entry!year!month!day!person!title!event\n";
1383
	my $index = 1;
1384
	while(my $e = shift @sorted_events) {
1385
		$e = $all_events{$e};
1386
		my $date = $e->{'date'};
1387
		if(!(defined($year)) || ($date->year() != $year)) {
1388
			$year = $date->year();
1389
			if($year) {
1390
				print $fout '</ul>';
1391
			}
1392
			print $fout "<h2>$year</h2><ul>";
1393
		}
1394
		my $person = $e->{'person'};
1395
		my $string = $person->as_string();
1396
		$string =~ s/'/\&apos;/g;
1397
		print $fout '<li>', @{$dtl->month_format_wide()}[$date->month() - 1], ' ',
1398
			$date->day(), ': <a href="',
1399
			make_filename_from_person(person => $person), '">',
1400
			$person->as_string(), '</a>: ', $e->{'event'}, '</li>';
1401
		print $csv "$index!$year!",
1402
			$date->month(), '!',
1403
			$date->day(), '!',
1404
			$person->xref(), '!',
1405
			"$string!",
1406
			$e->{'event'}, "\n";
1407
		$index++;
1408
	}
1409
	close $csv;
1410
	print $fout '</ul></body></html>';
1411
	close $fout;
1412
}
1413
1414
if($facts && open(my $json, '>', 'dynamic-site/databases/facts.json')) {
1415
	if(my $fb = $facts->{'first_birth'}) {
1416
		$facts->{'first_birth'}->{'date'} = $fb->{'date'}->strftime('%x');
1417
	}
1418
	if(my $oa = delete $facts->{'oldest_age'}->{'age'}) {
1419
		$facts->{'oldest_age'}->{'years'} = $oa->years();
1420
		$facts->{'oldest_age'}->{'months'} = $oa->months();
1421
		$facts->{'oldest_age'}->{'days'} = $oa->days();
1422
	}
1423
	print $json encode_json($facts);
1424
	close $json;
1425
}
1426
1427
sub print_person
1428
{
1429
	my %params = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
1430
1431
	# Gather the information on this person
1432
	my $person = $params{'person'};
1433
1434
	# $fetcher = Data::Fetch->new();	# Throw away old values from the cache
1435
1436
	my $dateofbirth = dateofbirth($person);
1437
1438
	# ACOM starts approximate dates with "Abt." instead of "ABT".
1439
	if(defined($dateofbirth) && length($dateofbirth) && ($dateofbirth ne '?')) {
1440
		$dateofbirth =~ tr/\.\-/  /;
1441
		$dateofbirth =~ s/\s{2,}/ /gs;
1442
		# FIXME: ../../../gedcoms/gl120368.ged puts dates *inside*
1443
		#	brackets
1444
		$dateofbirth =~ s/\(.+$//;	# some people put information in brackets after the date
1445
		if($dateofbirth =~ /^About[:\s](.+)/i) {
1446
			$dateofbirth = "ABT$1";
1447
		} elsif($dateofbirth =~ /^Bet\s[a-z]{3}.+([a-z]{3}\s+.*)/i) {	# Bet Jun-Jul 1860
1448
			$dateofbirth = "ABT $1";
1449
		} elsif($dateofbirth =~ /^(.+)\s*\?/i) {
1450
			$dateofbirth = "ABT$1";
1451
		}
1452
		if(length($dateofbirth) && ($dateofbirth !~ /^[\d\sA-Z\/]+$/i) && ($dateofbirth !~ /^Abt\./)) {
1453
			if($dateofbirth =~ /(\d{4})\s*(.+)/) {
1454
				my $d = $1;
1455
				my $t = $2;
1456
				# Allow 1914-1918
1457
				if($t !~ /\d{3,4}$/) {
1458
					$dateofbirth = "ABT$d";
1459
					if(place({ person => $person, place => $t })) {
1460
						complain({ person => $person, warning => "Unexpected text ($t) after the date $d - should be in the location record" });
1461
					} else {
1462
						complain({ person => $person, warning => "Unexpected text ($t) after the date $d - should be in the note field" });
1463
					}
1464
				}
1465
			} elsif($dateofbirth !~ /\d{1,2}$/) {	# Dates can begin with a letter in the US
1466
				complain({ person => $person, warning => "Invalid character in date of birth $dateofbirth" });
1467
				$dateofbirth = undef;
1468
			}
1469
		}
1470
	}
1471
1472
	print 'Processing ', $person->as_string({ include_years => 1 }), "\n" if($opts{'v'});
1473
1474
	my @siblings = $person->siblings();
1475
	my $mother = $person->mother();
1476
	my $father = $person->father();
1477
	my @spouses = $person->spouse();
1478
1479
	# TODO: Properly chart which spouse a child comes from
1480
	if($opts{'w'}) {
1481
		my $family;
1482
		foreach my $f($person->fams()) {
1483
			if($f->number_of_children()) {
1484
				$family = $f;
1485
				last;
1486
			}
1487
		}
1488
1489
		if((!$family) && (scalar(@siblings) == 0) && (!$mother) && !$father) {
1490
			if(scalar(@spouses) == 0) {
1491
				# This person isn't connected to anyone
1492
				# TODO: catch "islands" of people connected to each other, but nobody else
1493
				complain({ person => $person, warning => 'Not connected to the tree' });
1494
			} elsif(scalar(@spouses) == 1) {
1495
				my $spouse = $spouses[0];
1496
				my $sf;
1497
				foreach my $f($spouse->fams()) {
1498
					if($f->number_of_children()) {
1499
						$sf = $f;
1500
						last;
1501
					}
1502
				}
1503
				my @ss = $spouse->spouse();
1504
				if((!$sf) && (!$spouse->mother()) && (!$spouse->father()) && (!$spouse->siblings()) && (scalar(@ss) == 1)) {
1505
					complain({ person => $person, warning => 'Spouses connect to each other but no-one else' });
1506
				}
1507
			}
1508
		}
1509
		if((!$family) && (scalar(@siblings) == 1) && (scalar(@spouses) == 0) && (!$mother) && !$father) {
1510
			my $sibling = $siblings[0];
1511
			my $sf;
1512
			foreach my $f($sibling->fams()) {
1513
				if($f->number_of_children()) {
1514
					$sf = $f;
1515
					last;
1516
				}
1517
			}
1518
			my @ss = $sibling->spouse();
1519
			if((!$sf) && (!$sibling->mother()) && (!$sibling->father()) && (scalar(@ss) == 0)) {
1520
				complain({ person => $person, warning => 'Siblings connect to each other but no-one else' });
1521
			}
1522
		}
1523
1524
		# FIXME: needs to only complain about more than two biological parents
1525
		my @parents = $person->parents();
1526
		if(scalar(@parents) > 2) {
1527
			complain({ person => $person, warning => 'Has more than two parents' });
1528
		}
1529
	}
1530
1531
	my $year = (localtime)[5];
1532
	$year += 1900 if($year < 1900);
1533
1534
	my $dateofdeath = dateofdeath($person);
1535
1536
	my $yod;	# Year of death
1537
	if($dateofdeath) {
1538
		$yod = get_year_from_date($dateofdeath);
1539
		if(!defined($yod)) {
1540
			complain({ person => $person, warning => "Invalid date of death $dateofdeath" });
1541
		}
1542
	}
1543
1544
	my $yob;	# Year of birth
1545
	if($dateofbirth) {
1546
		if(($dateofbirth eq 'UNKNOWN') || ($dateofbirth eq '?')) {
1547
			$dateofbirth = undef;
1548
		} else {
1549
			$yob = get_year_from_date($dateofbirth);
1550
			if(!defined($yob)) {
1551
				complain({ person => $person, warning => "Invalid date of birth $dateofbirth" });
1552
			}
1553
		}
1554
	}
1555
1556
	my $name = $person->name();
1557
	$name =~ s/\///g;
1558
	$nameparser->parse($name);
1559
	my %name_components = $nameparser->components();
1560
	my $firstname = $name_components{'given_name_1'} // $name_components{'initials_1'};
1561
	# my $surname = $name_components{'surname_2'} || $name_components{'surname_1'};
1562
	my $surname = ucfirst(lc($person->surname())); # RT109786
1563
1564
	if((!defined($firstname)) && ($name =~ /(.+)\s(.+)/)) {
1565
		$firstname = $1;
1566
		if(!defined($surname)) {
1567
			$surname = $2;
1568
		}
1569
		complain({ person => $person, warning => "Can't parse the name - assuming first name: $firstname, last name: $surname" });
1570
	}
1571
1572
	if($firstname && ($firstname =~ /\d/)) {
1573
		complain({ person => $person, warning => 'First name contains a digit' });
1574
	}
1575
	if($surname) {
1576
		if($surname =~ /\d/) {
1577
			complain({ person => $person, warning => 'Last name contains a digit' });
1578
		} elsif($mother && $father && (uc($mother->surname()) ne uc($surname)) && (uc($father->surname()) ne uc($surname))) {
1579
			complain({ person => $person, warning => 'Neither parent has the same surname as this person' });
1580
		}
1581
	}
1582
1583
	# Ensure last name isn't used if the first name isn't known
1584
	if($yob && $firstname && $person->given_names()) {
1585
		push @{$name_date{floor($yob / 25)}{$firstname}}, $person->xref();
1586
	}
1587
1588
	my $is_alive = is_alive(person => $person);
1589
	my $title;
1590
	if($is_alive && !$opts{'l'}) {
1591
		print $csv $person->xref(), '!',
1592
			$person->as_string({ middle_names => 1, title => 1 }), '!';
1593
		$title = $firstname;
1594
	} else {
1595
		print $csv $person->xref(), '!',
1596
			$person->as_string({ include_years => 1, middle_names => 1, title => 1 }), '!';
1597
		$title = $person->as_string({
1598
			include_years => 1,
1599
			nee => 1,
1600
			middle_names => 1,
1601
			title => 1,
1602
		});
1603
	}
1604
1605
	print "Starting output\n" if($opts{'v'});
1606
1607
	open(my $html, '>', 'static-site/' . make_filename_from_person(person => $person));
1608
	my $xtitle = $title;
1609
	$xtitle =~ s/&eacute;/&#233;/g;
1610
	$xtitle =~ s/\xc3\xab/&#235;/g;	# eumlaut
1611
	print $xml "\n\t\t<entry>", $person->xref(),
1612
		"</entry>\n\t\t<title>$xtitle</title>";
1613
	if($firstname) {
1614
		$firstname =~ s/\xc3\xab/&#235;/g;	# eumlaut
1615
		print $xml "\n\t\t<first_name>$firstname</first_name>";
1616
	}
1617
	if($surname) {
1618
		print $xml "\n\t\t<surname>$surname</surname>";
1619
	}
1620
1621
	if($me && ($person->xref() eq $me->xref())) {
1622
		my $name = $person->as_string(nee => 1);
1623
1624
		open(my $html, '>', 'static-site/index.html');
1625
		print $html "<html><head><title>The Family Tree $name</title>",
1626
			'<meta http-equiv="Refresh" content="1;URL=', make_filename_from_person(person => $person), '">';
1627
		if(my $lang = $ENV{'LANG'}) {
1628
			$lang =~ s/\.UTF-8//;
1629
			$lang =~ tr/_/-/;
1630
			$lang = lc($lang);
1631
			print $html "<meta http-equiv=\"Content-Language\" content=\"$lang\">";
1632
		}
1633
		print $html '</head>',
1634
			"<body><h1>The Family Tree $name</h1><a href=\"", make_filename_from_person(person => $person), "\">$name</a></body></html>";
1635
		close $html;
1636
		print $xml "\n\t\t<home>1</home>";
1637
		print $csv '1!';
1638
	} else {
1639
		print $csv '0!';
1640
	}
1641
1642
	if($opts{'m'}) {
1643
		print $html "<html><head><title>$title</title></head><body onload=\"html_googlemaps_initialize()\"><center><h1>$title</h1>";
1644
	} else {
1645
		if($geolocation_key) {
1646
			die "$0: -G makes no sense without -m";
1647
		}
1648
		print $html "<html><head><title>$title</title></head><body><center><h1>$title</h1>";
1649
	}
1650
	if(defined($me)) {
1651
		print $html '[ <a href="', make_filename_from_person(person => $me), '">Home</a> ]';
1652
	}
1653
	if($gedcal) {
1654
		print $html ' | [ <a href="calendar/index.html">Calendar</a> ]';
1655
	}
1656
	print $html ' | [ <a href="surnames.html">Surnames Index</a> ]',
1657
		' | [ <a href="censuses.html">Census Index</a> ]';
1658
	if($opts{'w'}) {
1659
		print $html ' | [ <a href="todo.html">Errors</a> ]';
1660
	}
1661
	print $html ' | [ <a href="history.html">Family History</a> ]</center><p>';
1662
1663
	my $bio;
1664
	my $fullbio;
1665
1666
	if($is_alive && !$opts{'l'}) {
1667
		print $xml "\n\t\t<alive>1</alive>";
1668
		print $csv '1!';
1669
		my $str = '<i>This is the record of a living person, so not much data will be shown.</i></p><p>';
1670
		print $html $str;
1671
		print $csv $str;
1672
		print "Living person\n" if($opts{'v'});
1673
	} else {
1674
		print $csv '0!';
1675
		$surnames->{$surname}->{$title} = $person;
1676
	}
1677
1678
	my ($birth_dt, $marriage_dt, $death_dt);
1679
	my $birth = $person->get_record('birth');
1680
1681
	my $placeofbirth = get_value({ person => $person, value => 'birth place' });
1682
	if((!$placeofbirth) && $birth) {
1683
		$placeofbirth = $birth->place();
1684
	}
1685
1686
	if($placeofbirth && ($placeofbirth =~ /[,\.]\s*$/) && ($placeofbirth ne 'U.S.A.')) {
1687
		complain({ person => $person, warning => "Trailing punctuation in birth location, '$placeofbirth'" });
1688
		$placeofbirth =~ s/\s*[,\.]\s*$//;
1689
	}
1690
1691
	if($placeofbirth && ($placeofbirth =~ /^,/)) {
1692
		complain({ person => $person, warning => "Leading comma in birth location: $placeofbirth" });
1693
		$placeofbirth =~ s/^,\s*//g;
1694
	}
1695
1696
	my $placeofdeath = get_value({ person => $person, value => 'death place' });
1697
	my $death = $person->get_record('death');
1698
	if((!$placeofdeath) && $death) {
1699
		$placeofdeath = $death->place();
1700
	}
1701
1702
	if($placeofdeath && ($placeofdeath =~ /\s\s/)) {
1703
		complain({ person => $person, warning => 'Removing successive spaces from place of death' });
1704
		$placeofdeath =~ s/\s\s+/ /g;
1705
	}
1706
1707
	if($placeofdeath && ($placeofdeath =~ /,\s*$/)) {
1708
		complain({ person => $person, warning => 'Trailing comma in death location' });
1709
		$placeofdeath =~ s/\s*,\s*$//;
1710
	}
1711
	if($placeofdeath && ($placeofdeath =~ /^,/)) {
1712
		complain({ person => $person, warning => 'Leading comma in death location' });
1713
		1 while($placeofdeath =~ s/^,\s*//g);
1714
	}
1715
1716
	if($is_alive && ($placeofdeath || $dateofdeath)) {
1717
		die "BUG: $title is marked as alive yet we have death information";
1718
	}
1719
1720
	if($opts{'w'}) {
1721
		my $name = $person->name();
1722
		$name =~ s/\///g;
1723
		$nameparser->parse($name);
1724
		my %name_components = $nameparser->components();
1725
		my $firstname = $name_components{'given_name_1'} // $name_components{'initials_1'};
1726
		if($firstname && (my $lastname = $name_components{'surname_1'})) {
1727
			my %chronicling_params = ( ua => $cached_browser );
1728
			if($dateofbirth && ($dateofbirth =~ /(\d{4})$/)) {
1729
				if($1 <= 1789) {
1730
					$chronicling_params{'date_of_birth'} = 1789;
1731
				} else {
1732
					$chronicling_params{'date_of_birth'} = $1;
1733
				}
1734
			}
1735
			if($dateofdeath && ($dateofdeath =~ /(\d{4})$/)) {
1736
				if($1 >= 1963) {
1737
					$chronicling_params{'date_of_death'} = 1963;
1738
				} else {
1739
					$chronicling_params{'date_of_death'} = $1;
1740
				}
1741
			}
1742
			if($firstname) {
1743
				$chronicling_params{'firstname'} = $firstname;
1744
				if($lastname) {
1745
					$chronicling_params{'lastname'} = $lastname;
1746
				}
1747
			}
1748
			my $stateofbirth;
1749
			if($placeofbirth && (($placeofbirth =~ /USA$/) || ($placeofbirth =~ /United States$/)) && ($placeofbirth =~ /^.+,\s*([\w\s]+),[\w\s]+$/)) {
1750
				$stateofbirth = uc($1);
1751
				if($us->{code2state}{$stateofbirth}) {
1752
					$stateofbirth = $us->{code2state}{$stateofbirth};
1753
				} elsif(!$us->{state2code}{$stateofbirth}) {
1754
					complain({ person => $params{'person'}, warning => "Unknown state '$stateofbirth' in birth place $placeofbirth" });
1755
				}
1756
				$chronicling_params{'state'} = ucfirst(lc($stateofbirth));
1757
				chronicling_america($person, \%chronicling_params);
1758
1759
			}
1760
			if($placeofdeath && (($placeofdeath =~ /USA$/) || ($placeofdeath =~ /United States$/)) && ($placeofdeath =~ /^.+,\s*([\w\s]+),[\w\s]+$/)) {
1761
				my $stateofdeath = uc($1);
1762
				if($us->{code2state}{$stateofdeath}) {
1763
					$stateofdeath = $us->{code2state}{$stateofdeath};
1764
				} elsif(!$us->{state2code}{$stateofdeath}) {
1765
					complain({ person => $params{'person'}, warning => "Unknown state '$stateofdeath' in death place $placeofbirth" });
1766
				}
1767
				if((!defined($stateofbirth)) || (lc($stateofdeath) ne lc($stateofbirth))) {
1768
					$chronicling_params{'state'} = ucfirst(lc($stateofdeath));
1769
					# TODO: married and maiden names, could be two searches
1770
					chronicling_america($person, \%chronicling_params);
1771
				}
1772
			}
1773
		}
1774
	}
1775
1776
	my %citations;
1777
	my $citationcount = 0;
1778
	my @birthcitations;
1779
	my @deathcitations;
1780
	if($opts{'c'}) {
1781
		if($birth) {
1782
			my @s = $birth->source();
1783
			if($opts{'w'}) {
1784
				foreach my $s(@s) {
1785
					if((!defined(get_source({ gedcom => $ged, person => $person, source => $s }))) &&
1786
					    !defined($s->items())) {
1787
						complain({ person => $person, warning => 'Birth citation is missing a source' });
1788
					}
1789
				}
1790
			}
1791
			@s = sort { (get_source({ gedcom => $ged, person => $person, source => $a }) && get_source({ gedcom => $ged, person => $person, source => $b })) ? get_source({ gedcom => $ged, person => $person, source => $a })->title() cmp get_source({ gedcom => $ged, person => $person, source => $b })->title() : 0 } @s;
1792
			if(scalar(@s)) {
1793
				my $previous;
1794
				foreach my $src(@s) {
1795
					# $src = $ged->get_source($src) unless ref($src);
1796
					$src = get_source({ gedcom => $ged, person => $person, source => $src}) unless ref($src);
1797
					if(defined($src) && (my $title = $src->title())) {
1798
						next if($previous && ($title eq $previous));
1799
						$previous = $title;
1800
						push @birthcitations, ++$citationcount;
1801
						$citations{$citationcount} = $src;
1802
					} elsif($src->items()) {
1803
						my @items = $src->items();
1804 1
						if($items[0]->{'value'}) {
1805
							push @birthcitations, ++$citationcount;
1806
							$citations{$citationcount} = $items[0];
1807
						}
1808
					}
1809
				}
1810
			} elsif($opts{'w'} && ($opts{'l'} || !$is_alive)) {
1811
				if($dateofbirth) {
1812
					red_warning({ person => $person, warning => "Birth date ($dateofbirth) has no citations" });
1813
				} elsif($placeofbirth) {
1814
					complain({ person => $person, warning => "Birth place ($placeofbirth) has no citations" });
1815
				} else {
1816
					complain({ person => $person, warning => 'Birth record has no citations' });
1817
				}
1818
			}
1819
		}
1820
		if($death) {
1821
			my @s = $death->source();
1822
			if($opts{'w'}) {
1823
				foreach my $s(@s) {
1824
					if(!defined(get_source({ gedcom => $ged, person => $person, source => $s }))) {
1825
						complain({ person => $person, warning => 'Death citation is missing a source' });
1826
					}
1827
				}
1828
			}
1829
			@s = sort { (get_source({ gedcom => $ged, person => $person, source => $a }) && get_source({ gedcom => $ged, person => $person, source => $b })) ? get_source({ gedcom => $ged, person => $person, source => $a })->title() cmp get_source({ gedcom => $ged, person => $person, source => $b })->title() : 0 } @s;
1830
			if(scalar(@s)) {
1831
				foreach my $src(@s) {
1832
					$src = $ged->get_source($src) unless ref($src);
1833
					my $seen;
1834
					foreach my $bc(@birthcitations) {
1835 1
						if($src eq $citations{$bc}) {
1836
							push @deathcitations, $bc;
1837
							$seen++;
1838
							last;
1839
						}
1840
					}
1841
					if(!$seen) {
1842
						push @deathcitations, ++$citationcount;
1843
						$citations{$citationcount} = $src;
1844
					}
1845
				}
1846
			} elsif($opts{'l'} || !is_alive(person => $person)) {
1847
				if($dateofdeath) {
1848
					# my $dateismissing = 0;
1849
					# my @objects = $person->obje();
1850
					# foreach my $o(@objects) {
1851
						# my $obje;
1852
						# if(ref($o) eq 'Gedcom::Record') {
1853
							# $obje = $o;	# e.g. Ancestry
1854
						# } else {
1855
							# $obje = $ged->resolve_xref($o);	# e.g. FMP
1856
						# }
1857
						# foreach my $item($obje->items()) {
1858
							# next if($item->tag() ne '_DATE');
1859
							# if($item->value() eq $dateofdeath) {
1860
								# $dateismissing = 0;
1861
								# last;
1862
							# }
1863
						# }
1864
					# }
1865
					# if($dateismissing) {
1866
						complain({ person => $person, warning => "Death date ($dateofdeath) has no citations" });
1867
					# }
1868
				} elsif($placeofdeath) {
1869
					complain({ person => $person, warning => "Death place ($placeofdeath) has no citations" });
1870
				} else {
1871
					complain({ person => $person, warning => 'Death record exists with no date or place' });
1872
				}
1873
			}
1874
		}
1875
	}
1876
1877
	# $fetcher->prime(object => $person, message => 'sex')->prime(object => $person, message => 'pronoun');
1878
1879
	my $baptism = $person->get_record('baptism');
1880
	my $dateofbaptism = get_value({ person => $person, value => 'baptism date' });
1881
	if((!$dateofbaptism) && $baptism) {
1882
		$dateofbaptism = $baptism->date();
1883
	}
1884
	my $placeofbaptism = get_value({ person => $person, value => 'baptism place' });
1885
	if((!$placeofbaptism) && $baptism) {
1886
		$placeofbaptism = $baptism->place();
1887
	}
1888
1889
	my @events = $person->event();
1890
1891
	my $marriage = $person->get_record('marriage') || $person->get_record('fams marriage');
1892
	if((!defined($marriage)) && scalar(@spouses)) {
1893
		$marriage = $spouses[0]->get_record('marriage');
1894
		if((!defined($marriage)) && scalar(@spouses)) {
1895
			if(scalar(@events) == 1) {
1896
				my $event = $person->event();
1897
				if(!ref($event)) {
1898
					my $e = $person->tag_record('EVEN');
1899
					if(ref($e) eq 'Gedcom::Record') {
1900
						$event = $e;
1901
					}
1902
				}
1903
				if((ref($event) eq 'Gedcom::Record') &&
1904
				  ($event->type() eq 'Custom Marriage')) {
1905
					# FindMyPast
1906
					$marriage = $event;
1907
				}
1908
			} else {
1909
				foreach my $event(@events) {
1910
					if((ref($event) eq 'Gedcom::Record') &&
1911
					  ($event->type() eq 'Custom Marriage')) {
1912
						# FindMyPast
1913
						$marriage = $event;
1914
						last;
1915
					}
1916
				}
1917
			}
1918
		}
1919
	}
1920
	my $placeofmarriage = get_value({ person => $person, value => 'marriage place' });
1921
	if((!$placeofmarriage) && $marriage) {
1922
		$placeofmarriage = $marriage->place();
1923
	}
1924
	if($placeofmarriage && ($placeofmarriage =~ /.+,\s?(.+)$/)) {
1925
		my $c = $1;
1926
		if($c eq 'Scot') {
1927
			complain({ person => $person, warning => "$c: marriage country should be Scotland'" });
1928
			$placeofmarriage .= 'land';
1929
		}
1930
	}
1931
1932
	my $burial;
1933
	my $dateofburial;
1934
	my $placeofburial;
1935
	my $cremation;
1936
	my $dateofcremation;
1937
	my $placeofcremation;
1938
	if($burial = $person->get_record('burial')) {
1939
		$dateofburial = get_value({ person => $person, value => 'burial date' });
1940
		if(!$dateofburial) {
1941
			$dateofburial = $burial->date();
1942
		}
1943
		$placeofburial = get_value({ person => $person, value => 'burial place' });
1944
		if(!$placeofburial) {
1945
			$placeofburial = $burial->place();
1946
		}
1947
	} elsif($cremation = $person->get_record('cremation')) {
1948
		$dateofcremation = get_value({ person => $person, value => 'cremation date' });
1949
		if(!$dateofcremation) {
1950
			$dateofcremation = $cremation->date();
1951
		}
1952
		$placeofcremation = get_value({ person => $person, value => 'cremation place' });
1953
		if(!$placeofcremation) {
1954
			$placeofcremation = $cremation->place();
1955
		}
1956
	}
1957
1958
	if($is_alive && ($placeofburial || $dateofburial)) {
1959
		die "BUG: $title is marked as alive yet we have burial information";
1960
	}
1961
1962
	# Don't match date ranges
1963
	if($dateofbirth && ($dateofbirth !~ /\d{4}.+\d{4}/) &&
1964
	  ($birth_dt = $dfg->parse_datetime(date => $dateofbirth, quiet => 1))) {
1965
		if(defined($facts->{'first_birth'})) {
1966
			if($birth_dt < $facts->{'first_birth'}->{'date'}) {
1967
				$facts->{'first_birth'}->{'date'} = $birth_dt;
1968
				$facts->{'first_birth'}->{'xref'} = $person->xref();
1969
			}
1970
		} else {
1971
			$facts->{'first_birth'}->{'date'} = $birth_dt;
1972
			$facts->{'first_birth'}->{'xref'} = $person->xref();
1973
		}
1974
1975
		if($birth_dt && (my $spouse = $spouses[0])) {
1976
			my $sdob = dateofbirth($spouse);
1977
			if($sdob && (my $sbirth_dt = date_to_datetime(date => $sdob))) {
1978
				if($sbirth_dt > ($birth_dt + $fortyyears)) {
1979
					complain({
1980
						person => $person,
1981
						warning => 'Spouse born more than 40 years after date of birth'
1982
					});
1983
				} elsif($birth_dt > ($sbirth_dt + $fortyyears)) {
1984
					complain({
1985
						person => $person,
1986
						warning => 'Born more than 40 years after date of birth of spouse'
1987
					});
1988
				}
1989
			}
1990
		}
1991
	}
1992
1993
	my $dateofmarriage = get_value({ person => $person, value => 'marriage date' });
1994
	if((!$dateofmarriage) && $marriage) {
1995
		$dateofmarriage = $marriage->date();
1996
	}
1997
	if($dateofmarriage && ($dateofmarriage =~ /\d$/)) {
1998
		$marriage_dt = $dfg->parse_datetime(date => $dateofmarriage, quiet => 1);
1999
	}
2000
2001
	if($birth_dt && $marriage_dt && $opts{'w'} && ($marriage_dt < ($birth_dt + $sixteenyears))) {
2002
		complain({
2003
			person => $person,
2004
			warning => 'married when less than 16 years old'
2005
		});
2006
	}
2007
	# Don't match date ranges
2008
	if($dateofdeath && ($dateofdeath !~ /\d{4}.+\d{4}/)) {
2009
		$death_dt = $dfg->parse_datetime(date => $dateofdeath, quiet => 1);
2010
	}
2011
2012
	if($birth_dt && $death_dt) {
2013
		my $age_at_death = $death_dt - $birth_dt;
2014
		if(defined($facts->{'oldest_age'})) {
2015
			# FIXME: Handle when there are more than one person with this age
2016
			# FIXME: add base_datetime argument
2017
			if(DateTime::Duration->compare($age_at_death, $facts->{'oldest_age'}->{'age'}) > 0) {
2018
				$facts->{'oldest_age'}->{'age'} = $age_at_death;
2019
				$facts->{'oldest_age'}->{'xref'} = $person->xref();
2020
			}
2021
		} else {
2022
			$facts->{'oldest_age'}->{'age'} = $age_at_death;
2023
			$facts->{'oldest_age'}->{'xref'} = $person->xref();
2024
		}
2025
	}
2026
2027
	if($opts{'l'} || !$is_alive) {
2028
		# RT114091
2029
		if($birth_dt && ($birth_dt >= $year_1000)) {
2030
			$all_events{'B' . $person->xref()} = { person => $person, event => 'Birth', date => $birth_dt };
2031
		}
2032
		if($marriage_dt && ($marriage_dt >= $year_1000)) {
2033
			$all_events{'M' . $person->xref()} = { person => $person, event => 'Marriage', date => $marriage_dt };
2034
		}
2035
		if($death_dt && ($death_dt >= $year_1000)) {
2036
			$all_events{'D' . $person->xref()} = { person => $person, event => 'Death', date => $death_dt };
2037
		}
2038
	}
2039
2040
	my %place_records;
2041
2042
	if($placeofbirth) {
2043
		$place_records{'Birth'} = $birth;
2044
	}
2045
	if($placeofbaptism) {
2046
		if($ENV{'LANG'} =~ /^en_US/) {
2047
			$place_records{'Baptized'} = $baptism;
2048
		} else {
2049
			$place_records{'Baptised'} = $baptism;
2050
		}
2051
	}
2052
	if($placeofmarriage) {
2053
		$place_records{'Marriage'} = $marriage;
2054
	}
2055
	if($placeofdeath) {
2056
		$place_records{'Death'} = $death;
2057
	}
2058
	if($placeofburial) {
2059
		$place_records{'Burial'} = $burial;
2060
	}
2061
2062
	my $marriagecitation;
2063
	my @burialcitations;
2064
	if($opts{'c'}) {
2065
		if($marriage) {
2066
			print "Check marriage source\n" if($opts{'v'});
2067
			if(my $src = $marriage->source()) {
2068
				$src = $ged->get_source($src) unless ref($src);
2069
				# FIXME:  Only looks for matches in the first citations
2070
				if(!defined($src)) {
2071
					my $src = $marriage->source();
2072
					complain({ person => $person, warning => "marriage citation can't find source $src" });
2073
				} elsif($birthcitations[0] && ($citations{$birthcitations[0]} eq $src)) {
2074
					$marriagecitation = $birthcitations[0];
2075
				} elsif($birthcitations[1] && ($citations{$birthcitations[1]} eq $src)) {
2076
					$marriagecitation = $birthcitations[1];
2077
				} elsif($deathcitations[0] && ($citations{$deathcitations[0]} eq $src)) {
2078
					$marriagecitation = $deathcitations[0];
2079
				} else {
2080
					$marriagecitation = ++$citationcount;
2081
					$citations{$marriagecitation} = $src;
2082
				}
2083
			} elsif($opts{'w'} && ($opts{'l'} || !$is_alive)) {
2084
				if($dateofmarriage) {
2085
					red_warning({ person => $person, warning => "Marriage date ($dateofmarriage) has no citations" });
2086
				} elsif($placeofmarriage) {
2087
					red_warning({ person => $person, warning => "Marriage place ($placeofmarriage) has no citations" });
2088
				} else {
2089
					red_warning({ person => $person, warning => 'Marriage record has no citations' });
2090
				}
2091
			}
2092
		}
2093
		if($burial) {
2094
			print "Check burial source\n" if($opts{'v'});
2095
			my @s = $burial->source();
2096
			if(scalar(@s)) {
2097
				foreach my $src(@s) {
2098
					$src = $ged->get_source($src) unless ref($src);
2099
					if(!defined($src)) {
2100
						my $src = $burial->source();
2101
						complain({ person => $person, warning => "burial citation can't find source $src" });
2102
						next;
2103
					}
2104
					my $seen;
2105
					foreach my $dc(@deathcitations) {
2106 1
						if($src eq $citations{$dc}) {
2107
							push @burialcitations, $dc;
2108
							$seen++;
2109
							last;
2110
						}
2111
					}
2112
					if(!$seen) {
2113 1
						if($marriagecitation && ($citations{$marriagecitation} eq $src)) {
2114
							push @burialcitations, $marriagecitation;
2115
						} else {
2116
							push @burialcitations, ++$citationcount;
2117
							$citations{$citationcount} = $src;
2118
						}
2119
					}
2120
				}
2121
			} elsif($opts{'w'} && ($opts{'l'} || !$is_alive)) {
2122
				if($dateofburial) {
2123
					complain({ person => $person, warning => "Burial date ($dateofburial) has no citations" });
2124
				} elsif($dateofcremation) {
2125
					complain({ person => $person, warning => "Cremation date ($dateofcremation) has no citations" });
2126
				} elsif($placeofburial) {
2127
					complain({ person => $person, warning => "Burial place ($placeofburial) has no citations" });
2128
				} else {
2129
					complain({ person => $person, warning => "Cremation place ($placeofcremation) has no citations" });
2130
				}
2131
			}
2132
		}
2133
	}
2134
2135
	my $pronoun = $person->pronoun();
2136
	my $sex = $person->sex();
2137
2138
	$facts->{'count'}++;
2139
	$facts->{'sex'}->{$sex}++;
2140
2141
	if($opts{'w'} && $firstname) {
2142
		# FIXME: This throws up a number of false positives
2143
		my $guess;
2144
		if($placeofbirth && ($placeofbirth =~ /, USA$/)) {
2145
			$guess = Text::Names::guessGender($firstname);
2146
		} else {
2147
			$guess = Text::Names::GB::guessGender($firstname);
2148
		}
2149
		if($sex && $guess && ($sex ne $guess)) {
2150
			my $error = 1;
2151
			if(my $middle_name = $name_components{'middle_name'}) {
2152
				if($placeofbirth && ($placeofbirth =~ /, USA$/)) {
2153
					$guess = Text::Names::guessGender($middle_name);
2154
				} else {
2155
					$guess = Text::Names::GB::guessGender($middle_name);
2156
				}
2157
				if($guess && ($sex eq $guess)) {
2158
					$error = 0;
2159
				}
2160
			}
2161
			if($error) {
2162
				complain({ person => $person, warning => 'Check the gender of the record' });
2163
			}
2164
		}
2165
	}
2166
	my @children = map { $_->children() } $person->fams();
2167
	my $numberofchildren = scalar(@children);
2168
2169
	if($opts{'w'} && $numberofchildren) {
2170
		foreach my $child(@children) {
2171
			if($child->xref() eq $person->xref()) {
2172
				complain({ person => $person, warning => 'person is own parent' });
2173
				# Avoid loops in G::I::Relationship
2174
				return;
2175
			}
2176
		}
2177
	}
2178
2179
	print "numberofchildren = $numberofchildren\n" if($opts{'v'});
2180
2181
	my $relationship;
2182
	my $spouserelationship;
2183
	my $spouse;
2184
	my %places_printed;
2185
2186
	if($dateofbirth && $opts{'w'} && scalar(@siblings)) {
2187
		print 'Found ', scalar(@siblings), " siblings(s)\n" if($opts{'v'});
2188
		foreach my $sibling(@siblings) {
2189
			if(($sibling->name() eq $person->name()) || Text::Names::samePerson($sibling->name(), $person->name())) {
2190
				my $siblingbirth = dateofbirth($sibling);
2191
				if($siblingbirth && ($siblingbirth eq $dateofbirth)) {
2192
					complain({ person => $sibling, warning => 'possible duplicate person' });
2193
				} elsif((!$dateofdeath) && !dateofdeath($sibling)) {
2194
					complain({ person => $sibling, warning => 'two siblings of the same name alive at the same time'});
2195
				}
2196
			}
2197
		}
2198
	}
2199
2200
	if($me && ($person->xref() ne $me->xref())) {
2201
		print "find relationship\n" if($opts{'v'});
2202
		$relationship = $me->relationship($person);
2203
		if((!$relationship) && scalar(@spouses)) {
2204
			print "find spousal relationship\n" if($opts{'v'});
2205
			if($spouses[0] eq $me) {
2206
				if($language eq 'French') {
2207
					$relationship = ($sex eq 'F') ? 'femme' : 'mari';
2208
				} elsif($language eq 'Latin') {
2209
					$relationship = ($sex eq 'F') ? 'uxor' : 'maritus';
2210
				} else {
2211
					$relationship = ($sex eq 'F') ? 'wife' : 'husband';
2212
				}
2213
			} else {
2214
				foreach my $s(@spouses) {
2215
					$spouserelationship = $me->relationship($s);
2216
					if($spouserelationship) {
2217
						$spouse = $s;
2218
						last;
2219
					}
2220
				}
2221
			}
2222
		}
2223
		if((!$relationship) && (!$spouserelationship)) {
2224
			complain({
2225
				person => $person,
2226
				warning => "Can't find relationship with the home person"
2227
			});
2228
		}
2229
		print 'relationship = ', ($relationship ? $relationship : 'unknown'), "\n" if($opts{'v'});
2230
		if(my $r = $relationship) {
2231
			# Remove spaces from the relationship so that the Template Toolkit can
2232
			# use it as a key
2233
			$r =~ s/ /_/g;
2234
			$facts->{'relations'}->{$r}++;
2235
		}
2236
	}
2237
2238
	if(($dateofbaptism || $placeofbaptism) && !($mother || $father) && $relationship) {
2239
		complain({ person => $person, warning => 'Baptism information not used to determine a parent' });
2240
	}
2241
2242
	my @occupations = get_all_occupations($person);
2243
2244
	print 'Found ', scalar(@occupations), " occupation(s)\n" if($opts{'v'});
2245
2246
	my $same_occupation_as_father;
2247
	my $printed_comma = 0;
2248
2249
	if($occupations[0]) {
2250
		my @foccupations;
2251
		if($father) {
2252
			@foccupations = get_all_occupations(person => $father);
2253
		}
2254
		if(scalar(@foccupations) && ($occupations[0] eq $foccupations[0])) {
2255
			$same_occupation_as_father = $occupations[0];
2256
			@occupations = ();
2257
		} else {
2258
			$bio = 'A';
2259
			if($occupations[0] =~ /^[aeiou]/i) {
2260
				$bio .= 'n';
2261
			}
2262
			$bio .= ' ';
2263
			if($occupations[1]) {
2264
				# my $alloccupations = join(', ', @occupations);
2265
				# substr($alloccupations, rindex($alloccupations, ', '), 2, ' and ');
2266
				# $bio .= HTML::Entities::encode(lc($alloccupations));
2267
				$bio .= lc(Lingua::EN::Inflect::WORDLIST(@occupations, {final_sep => ''}));
2268
			} else {
2269
				$bio .= lc($occupations[0]);
2270
			}
2271
			if(!($father || $mother || $spouserelationship)) {
2272
				$bio .= ', ';
2273
				$printed_comma = 1;
2274
			}
2275
		}
2276
	}
2277
2278
	my @person_twins;
2279
	if($birth_dt && ($opts{'l'} || !$is_alive)) {
2280
		foreach my $s(@siblings) {
2281
			if(my $dob = dateofbirth($s)) {
2282
				if(($dob =~ /^\d/) && ($dob !~ /[a-z]$/i)) {
2283
					my $d;
2284
					eval {
2285
						$d = $date_parser->parse(date => $dob);
2286
					};
2287
					if($d) {
2288 1
						if($d = @{$d}[0]) {
2289
							$d = $dfn->parse_datetime($d->{'canonical'});
2290 1
							if(($d == $birth_dt) || ($d == ($birth_dt - $oneday)) || ($d == ($birth_dt + $oneday))) {
2291
								push @person_twins, $s;
2292
								$twins{$person->xref()} = $s->xref();
2293
							}
2294
						}
2295
					}
2296
				}
2297
			}
2298
		}
2299
		if(scalar(@person_twins) == 1) {	# TODO triplets and higher order
2300
			if(scalar(@occupations)) {
2301
				$bio .= ', twin of ' . $person_twins[0]->given_names();
2302
			} else {
2303
				$bio .= 'The twin ' . (($person->sex() eq 'M') ? 'brother' : 'sister') .
2304
					' of ' . $person_twins[0]->given_names();
2305
			}
2306
			$printed_comma = 0;
2307
		}
2308
	}
2309
2310
	print $xml "\n\t\t<bio>\n\t\t\t<en>\n\t\t\t\t";
2311
2312
	my $print_sibling_count = 0;
2313
	my $html_and_csv = File::Print::Many->new([$csv, $html]);
2314
	# my $html_and_xml = File::Print::Many->new([$xml, $html]);
2315
	my $all = File::Print::Many->new([$xml, $html, $csv]);
2316
2317
	if($father || $mother) {
2318
		if(scalar(@occupations) || scalar(@person_twins)) {
2319
			$bio .= ' and the ';
2320
		} else {
2321
			$bio = 'The ';
2322
		}
2323
2324
		if($birth_dt && ($opts{'l'} || !$is_alive)) {
2325
			if(scalar(@siblings)) {
2326
				# If possible, sort siblings by date of birth
2327
				my $all_siblings_have_dob = 1;
2328
				foreach my $sibling(@siblings) {
2329
					if(my $dob = dateofbirth($sibling)) {
2330 1
						if(($dob !~ /^\d/) || ($dob =~ /[a-z]$/i) ||
2331
						   ($dob =~ /[\/\-]/) || !date_parser_cached(date => $dob)) {
2332
							$all_siblings_have_dob = 0;
2333
							last;
2334
						}
2335 1
						if(!date_parser_cached(date => $dob)) {
2336
							complain({
2337
								person => $sibling,
2338
								warning => "has an invalid date of birth: $dob"
2339
							});
2340
							$all_siblings_have_dob = 0;
2341
							last;
2342
						}
2343
					} else {
2344
						$all_siblings_have_dob = 0;
2345
						last;
2346
					}
2347
				}
2348
				if($all_siblings_have_dob) {
2349
					@siblings = Sort::Key::DateTime::dtkeysort { $dfn->parse_datetime(@{$date_parser->parse(date => dateofbirth($_))}[0]->{'canonical'}) } @siblings;
2350
				}
2351
				my $age_index = 1;	# count of siblings born before $person + 1 (i.e. where $person is in the date order)
2352
				$print_sibling_count = 1;
2353
				foreach my $sibling(@siblings) {
2354
					if(my $dob = dateofbirth($sibling)) {
2355
						if(my $d = date_parser_cached(date => $dob)) {
2356
							$d = $dfn->parse_datetime($d->{'canonical'});
2357
							if($opts{'w'} &&
2358
							  ($dob =~ /^\d/) && ($dob !~ /[a-z]$/i) &&
2359
							  ($d < $birth_dt) &&
2360
							  ($d < ($birth_dt - $oneday)) &&
2361
							  ($d > ($birth_dt - $tenmonths))) {
2362
								complain({
2363
									person => $sibling,
2364
									warning => 'Born less than 10 months before sibling ' . $person->as_string()
2365
								});
2366
							}
2367
							$age_index++ if($d && ($d < $birth_dt));
2368
						} else {
2369
							$all_siblings_have_dob = 0;
2370
							last;
2371
						}
2372
					} else {
2373
						$all_siblings_have_dob = 0;
2374
						last;
2375
				}
2376
				}
2377
				if($all_siblings_have_dob) {
2378
					if($language eq 'French') {
2379
						$bio .= 'e ';
2380
					}
2381
					if(scalar(@siblings) && ($age_index == (scalar(@siblings) + 1))) {
2382
						if($language eq 'French') {
2383
							$bio .= ($sex eq 'M') ? 'dernier' : 'dernière';
2384
						} else {
2385
							$bio .= ((scalar(@siblings) > 1) ? 'youngest' : 'younger');
2386
						}
2387
					} elsif(scalar(@siblings) && ($age_index == 1)) {
2388
						$bio .= ((scalar(@siblings) > 1) ? 'eldest' : 'older');
2389
					} elsif($language eq 'French') {
2390
						$bio .= Lingua::FR::Numbers::Ordinate::ordinate($age_index);
2391
					} else {
2392
						$bio .= ordinate($age_index);
2393
					}
2394
					if($language eq 'French') {
2395
						$bio .= ' de ' . (scalar(@siblings) + 1) . ' enfants';
2396
					} else {
2397
						$bio .= ' of ' . (scalar(@siblings) + 1) . ' children';
2398
					}
2399
				} else {
2400
					if($language eq 'French') {
2401
						$bio .= "'enfant";
2402
					} else {
2403
						$bio .= 'child';
2404
					}
2405
				}
2406
			} else {
2407
				# $bio .= ' only child of';
2408
				$bio .= 'child';
2409
			}
2410
		} else {
2411
			$bio .= 'child';
2412
		}
2413
2414
		$bio .= ' of';
2415
2416
		print $csv $bio;
2417
		$bio =~ s/\s&\s/ &amp; /g;
2418
		print $html $bio;
2419
		$bio =~ s/&eacute;/&#233;/g;
2420
		print $xml $bio;
2421
2422
		$fullbio = $bio;
2423
		$bio = undef;
2424
2425
		if($opts{'l'} || !$is_alive) {
2426
			if($father) {
2427
				print $html ' <a href="', make_filename_from_person(person => $father), '">',
2428
					$father->as_string(),
2429
					'</a>';
2430
				print $xml ' &lt;a href="?page=people&amp;entry=', $father->xref(), '"&gt;'.
2431
					$father->as_string(),
2432
					'$lt;/a$gt;';
2433
				print $csv ' <a href="?page=people&entry=', $father->xref(), '">'.
2434
					$father->as_string(),
2435
					'</a>';
2436
2437
				if(!$same_occupation_as_father) {
2438
					my @occupations = get_all_occupations(person => $father);
2439
					# TODO: print all occupations
2440
					if(my $occupation = $occupations[0]) {
2441
						$occupation = lc($occupation);
2442
						if($language eq 'English') {
2443
							if($ENV{'LANG'} =~ /^en_US/) {
2444
								$occupation = Lingua::EN::ABC::b2a($occupation);
2445
							} elsif($ENV{'LANG'} =~ /^en_CA/) {
2446
								$occupation = Lingua::EN::ABC::b2c($occupation);
2447
							} else {
2448
								$occupation = Lingua::EN::ABC::a2b($occupation);
2449
							}
2450
						}
2451
						if($language eq 'English') {
2452
							$all->print(' (', HTML::Entities::encode(Lingua::EN::Inflect::A(lc($occupation))), ')');
2453
						} else {
2454
							$all->print(" (un $occupation)");
2455
						}
2456
					}
2457
				}
2458
				$fullbio .= ' ' . $father->as_string();
2459
				if($mother) {
2460
					$all->print(' and');
2461
					$fullbio .= ' and';
2462
				}
2463
			}
2464
			if($mother) {
2465
				if(my $m = $mother->as_string(give_maidenname => 0)) {
2466
					print $html ' <a href="', make_filename_from_person(person => $mother), "\">$m</a>";
2467
					print $csv ' <a href="?page=people&entry=', $mother->xref(), "\">$m</a>";
2468
					print $xml ' &lt;a href="?page=people&amp;entry=', $mother->xref(), "\"&gt;$m&lt;/a&gt;";
2469
				}
2470
2471
				my @occupations = get_all_occupations($mother);
2472
				# TODO: print all occupations
2473
				if($occupations[0]) {
2474
					$all->print(' (', Lingua::EN::Inflect::A(lc($occupations[0])), ')');
2475
				}
2476
				$fullbio .= ' ' . $mother->as_string();
2477
				if($opts{'w'} && $birth_dt && (my $mdod = dateofdeath($mother))) {
2478
					if(my $dt = date_to_datetime(date => $mdod)) {
2479
						if($birth_dt > $dt) {
2480
							complain({ person => $person, warning => 'Born after mother died' });
2481
						}
2482
					}
2483
				}
2484
			}
2485
		} else {
2486
			if($father) {
2487
				print $html ' <a href="', make_filename_from_person(person => $father), '">',
2488
					$father->given_names(),
2489
					'</a>';
2490
				print $csv ' <a href="?page=people&entry=', $father->xref(), '">',
2491
					$father->given_names(),
2492
					'</a>';
2493
				print $xml ' &lt;a href="?page=people&amp;entry=', $father->xref(), '"&gt;',
2494
					$father->given_names(),
2495
					'&lt;/a&gt;';
2496
				if($mother) {
2497
					$all->print(' and');
2498
				}
2499
			}
2500
			if($mother) {
2501
				print $html ' <a href="', make_filename_from_person(person => $mother), '">',
2502
					$mother->given_names(),
2503
					'</a>';
2504
				print $csv ' <a href="?page=people&entry=', $mother->xref(), '">',
2505
					$mother->given_names(),
2506
					'</a>';
2507
				print $xml ' &lt;a href="?page=people&amp;entry=', $mother->xref(), '"&gt;',
2508
					$mother->given_names(),
2509
					'&lt;/a&gt;';
2510
			}
2511
		}
2512
		$printed_comma = 0;
2513
	}
2514
2515
	if($firstname) {
2516
		if((!$is_alive) || $opts{'l'} || (!defined($me)) || ($person->xref() ne $me->xref())) {
2517
			if($opts{'l'} || $is_alive) {
2518
				if($relationship) {
2519
					$bio .= ', ' if(($mother || $father) && !$printed_comma);
2520
					$bio .= "<b>$firstname</b>";
2521
					if(($dateofbirth || $marriage) && (!($is_alive || $opts{'l'}))) {
2522
						$bio .= ',';
2523
					} elsif($is_alive) {
2524
						$bio .= ' is';
2525
					} else {
2526
						$bio .= ' was';
2527
					}
2528
				}
2529
			} else {
2530
				if($father || $mother || $occupations[0]) {
2531
					$bio .= ', ' if(!$printed_comma);
2532
				}
2533
				if($name_components{'surname_1'}) {
2534
					$bio .= "<b>$firstname " .
2535
						$name_components{'surname_1'} .
2536
						'</b>';
2537
				} else {
2538
					$bio .= "<b>$firstname</b>";
2539
				}
2540
				if($relationship) {
2541
					if($dateofbirth || $dateofbaptism || $placeofbirth || $placeofbaptism || scalar(@spouses)) {
2542
						$bio .= ',';
2543
					} elsif($opts{'l'} || $is_alive) {
2544
						$bio .= ' is';
2545
					} else {
2546
						$bio .= ' was';
2547
					}
2548
				}
2549
			}
2550
		}
2551
	} else {
2552
		$bio .= $pronoun;
2553
	}
2554
2555
	if($bio) {
2556
		$html_and_csv->print($bio);
2557
		print $xml HTML::Entities::encode($bio);
2558
2559
		$fullbio .= $bio;
2560
	}
2561
	$bio = '';
2562
2563
	my $haveprintedspousename;
2564
	if($relationship) {
2565
		print $html " the $relationship of ",
2566
			'<a href="', make_filename_from_person(person => $me), '">',
2567
			$me->as_string(nee => 1),
2568
			'</a>';
2569
		print $csv " the $relationship of ",
2570
			'<a href="?page=people&home=1">',
2571
			$me->as_string(nee => 1),
2572
			'</a>';
2573
		print $xml " the $relationship of ",
2574
			'&lt;a href="?page=people&amp;home=1"&gt;',
2575
			$me->as_string(nee => 1),
2576
			'&lt;/a&gt;';
2577
	} elsif($spouserelationship) {
2578
		if($sex eq 'F') {
2579
			$all->print(', the wife of');
2580
		} else {
2581
			$all->print(', the husband of');
2582
		}
2583
		my $s = $spouse->as_string({ middle_names => 1, title => 1 });
2584
		if(!defined($s)) {
2585
			complain({ person => $spouse, warning => 'Seems to have no name' });
2586
			$s = 'your relation';
2587
		}
2588
		print $html ' <a href="', make_filename_from_person(person => $spouse), '">',
2589
			"$s</a> the $spouserelationship of ",
2590
			'<a href="', make_filename_from_person(person => $me), '">',
2591
			$me->as_string(nee => 1),
2592
			'</a>';
2593
		print $csv ' <a href="?page=people&entry=', $spouse->xref(), '">',
2594
			"$s</a> the $spouserelationship of ",
2595
			'<a href="?page=people&home=1">',
2596
			$me->as_string(nee => 1),
2597
			'</a>';
2598
		$s =~ s/\xc3\xab/&#235;/g;	# eumlaut
2599
		print $xml ' &lt;a href="?page=people&amp;entry=', $spouse->xref(), '"&gt;',
2600
			"$s&lt;/a&gt; the $spouserelationship of ",
2601
			'&lt;a href="?page=people&amp;home=1"&gt;',
2602
			$me->as_string(nee => 1),
2603
			'&lt;/a&gt;';
2604
		if($dateofbirth || $dateofbaptism || $placeofbirth || $placeofbaptism || $dateofmarriage) {
2605
			print $html ',';
2606
			print $csv ',';
2607
			print $xml ',';
2608
		}
2609
		$haveprintedspousename = 1;
2610
	}
2611
2612
	if(my $aka = $person->as_string({ use_aka => 1 })) {
2613
		$html_and_csv->print(" (also known as $aka)");
2614
		$aka =~ s/&eacute;/&#233;/g;
2615
		print $xml " (also known as $aka)";
2616
	}
2617
2618
	my $start_of_paragraph = 0;
2619
	my $end_of_sentence = 0;
2620
2621
	my @childrenunknownparent;
2622
	my @residences = get_all_residences($person);
2623
	if($opts{'l'} || !$is_alive) {
2624
		my $all_children_are_alive = 1;
2625
2626
		if($yob && ($year >= $yob + 150)) {
2627
			$all_children_are_alive = 0;
2628
		} else {
2629
			foreach my $child(@children) {
2630
				if(!is_alive(person => $child)) {
2631
					$all_children_are_alive = 0;
2632
					last;
2633
				}
2634
			}
2635
		}
2636
2637
		if(($dateofbirth || $dateofbaptism || $placeofbirth || $placeofbaptism)) {
2638
			if($dateofbirth || $placeofbirth) {
2639
				# print $html ',' if($print_sibling_count && (!$opts{'a'}) && !$opts{'p'});
2640
2641
				$bio = ',' if($relationship);
2642
				$bio .= ' was born';
2643
				if($placeofbirth) {
2644
					my $p = place({ person => $person, place => $placeofbirth });
2645
					$bio .= $p;
2646
					$places_printed{$p} = 1;
2647
				} else {
2648
					complain({ person => $person, warning => 'Date of birth is known, but not place' });
2649
				}
2650
				if($dateofbirth) {
2651
					my $y = year({
2652
						person => $person,
2653
						date => $dateofbirth,
2654
						must_predate => $death_dt
2655
					});
2656
					if($y =~ /^fro?m (.+) to (.+)/i) {
2657
						$y = "between $1 and $2";
2658
					}
2659
					$bio .= " $y" if($y);
2660
				}
2661
				$bio .= cite(@birthcitations);
2662
				if($dateofbaptism || $placeofbaptism) {
2663
					if(scalar(@spouses) && ($numberofchildren > 0)) {
2664
						$bio .= ', was';
2665
					} else {
2666
						$bio .= ' and';
2667
					}
2668
				}
2669
				$end_of_sentence = 0;
2670
			}
2671
			if($opts{'w'}) {
2672
				if($mother && $yob && (my $mumdateofbirth = dateofbirth($mother))) {
2673
					if($mumdateofbirth =~ /.*?(\d{3,4})/) {
2674
						$mumdateofbirth = $1;
2675
						if(($yob - $mumdateofbirth) <= 13) {
2676
							complain({
2677
								person => $person,
2678
								warning => "Something is wrong with the date of birth which is less than 13 years after the mother was born ($mumdateofbirth)"
2679
							});
2680
						} elsif(($yob - $mumdateofbirth) >= 52) {
2681
							complain({
2682
								person => $person,
2683
								warning => "Something is wrong with the date of birth which is more than 52 years after the mother was born ($mumdateofbirth)"
2684
							});
2685
						}
2686
					}
2687
				}
2688
				if($father && $yob && (my $daddateofbirth = dateofbirth($father))) {
2689
					if($daddateofbirth =~ /.*?(\d{3,4})/) {
2690
						$daddateofbirth = $1;
2691
						if(($yob - $daddateofbirth) <= 13) {
2692
							complain({
2693
								person => $person,
2694
								warning => "Something is wrong with the date of birth which is less than 13 years after the father was born ($daddateofbirth)"
2695
							});
2696
						}
2697
					}
2698
				}
2699
				if($birth_dt || ($dateofbirth && ($dateofbirth=~ /^\d{3,4}$/))) {
2700
					# TODO: Add more checking
2701
					my $yob;
2702
					if($birth_dt) {
2703
						$yob = $birth_dt->year();
2704
					} elsif($dateofbirth =~ /^(\d{3,4})$/) {
2705
						$yob = $1;
2706
					} else {
2707
						die "BUG: Impossible case";
2708
					}
2709
					foreach my $dc(@deathcitations) {
2710
						my $citation = $citations{$dc};
2711
						if(my $title = $citation->title()) {
2712
							if($title =~ /^(\d{3,4})\s/) {
2713
								if($1 < $yob) {
2714
									complain({
2715
										person => $person,
2716
										warning => "Year of citation of $title is before the birth year of $yob"
2717
									});
2718
								}
2719
							}
2720
						}
2721
					}
2722
				}
2723
				if($death_dt || ($dateofdeath && ($dateofdeath =~ /^\d{3,4}$/))) {
2724
					my $yod;
2725
					# TODO: Add more checking
2726
					if($death_dt) {
2727
						$yod = $death_dt->year();
2728
					} elsif($dateofdeath =~ /^(\d{3,4})$/) {
2729
						$yod = $1;
2730
					} else {
2731
						die "BUG: Impossible case";
2732
					}
2733
					foreach my $bc(@birthcitations) {
2734
						my $citation = $citations{$bc};
2735
						if(my $title = $citation->title()) {
2736
							if($title =~ /^(\d{3,4})\s/) {
2737
								if($1 > $yod) {
2738
									complain({
2739
										person => $person,
2740
										warning => "Year of citation of $title is after the death year of $yod"
2741
									});
2742
								}
2743
							}
2744
						}
2745
					}
2746
				}
2747
			}
2748
			if($dateofbaptism || $placeofbaptism) {
2749
				$bio .= ' ';
2750
				unless($dateofbirth || $placeofbirth) {
2751
					if(($numberofchildren == 0) || (scalar(@spouses) == 0) || $all_children_are_alive) {
2752
						$bio .= 'and ';
2753
					}
2754
					$bio .= 'was ';
2755
				}
2756
				if($ENV{'LANG'} =~ /^en_US/) {
2757
					$bio .= 'baptized';
2758
				} else {
2759
					$bio .= 'baptised';
2760
				}
2761
				if($placeofbaptism) {
2762
					if($placeofbirth && ($placeofbaptism eq $placeofbirth)) {
2763
						$bio .= ' there';
2764
						if(my $address = $baptism->address()) {
2765
							if($address =~ /(.+),\s*$placeofbirth$/) {
2766
								$address = $1;
2767
							}
2768
							$bio .= " at $address";
2769
						}
2770
					} else {
2771
						my $p = place({ person => $person, place => $placeofbaptism });
2772
						$bio .= $p;
2773
						$places_printed{$p} = 1;
2774
					}
2775
				}
2776
				if($dateofbaptism) {
2777
					if($opts{'w'} && $yob && ($dateofbaptism =~ /(\d{3,4})$/)) {
2778
						# must_predate doesn't work when only years are known
2779
						if($1 < $yob) {
2780
							if($opts{'f'}) {
2781
								die $person->as_string(), ": Year of baptism $1 is before the year of birth $yob";
2782
							}
2783
							red_warning({
2784
								person => $person,
2785
								warning => "Year of baptism $1 is before the year of birth $yob"
2786
							});
2787
						}
2788
					}
2789
					$bio .= ' ' . year({
2790
						person => $person,
2791
						date => $dateofbaptism,
2792
						must_postdate => $birth_dt,
2793
						must_predate => $death_dt
2794
					}) . sibling_baptism_string({
2795
						person => $person,
2796
						siblings => \@siblings,
2797
						date => $dateofbaptism,
2798
						birthdate => $dateofbirth,
2799
					});
2800
					if(!$death_dt) {
2801
						must_predate({
2802
							person => $person,
2803
							date => $dateofbaptism,
2804
							predate => $dateofdeath
2805
						});
2806
					}
2807
				}
2808
			} elsif($birth_dt) {
2809
				my @person_twins;
2810
				foreach my $s(@siblings) {
2811
					if(my $dob = dateofbirth($s)) {
2812
						if(($dob =~ /^\d/) && ($dob !~ /[a-z]$/i)) {
2813
							my $d;
2814
							eval {
2815
								$d = $date_parser->parse(date => $dob);
2816
							};
2817
							if($d) {
2818
								$d = @{$d}[0];
2819
							}
2820
							if($d) {
2821
								$d = $dfn->parse_datetime($d->{'canonical'});
2822
								if(($d == $birth_dt) || ($d == ($birth_dt - $oneday)) || ($d == ($birth_dt + $oneday))) {
2823
									push @person_twins, { sibling => $s, dob => $d };
2824
									if($opts{'l'} || !$is_alive) {
2825
										$twins{$person->xref()} = $s->xref();
2826
									}
2827
								}
2828
							}
2829
						}
2830
					}
2831
				}
2832
				if(scalar(@person_twins) == 1) {	# TODO triplets and higher order
2833
					my $t = $person_twins[0];
2834
					my $sibling = $t->{'sibling'};
2835
					my $dob = $t->{'dob'};
2836
					if($dob == $birth_dt) {
2837
						$bio .= ' along with ';
2838
					} elsif($dob == ($birth_dt + $oneday)) {
2839
						$bio .= ', a day before ';
2840
					} else {
2841
						$bio .= ', a day after ';
2842
					}
2843
					$bio .= ($sex eq 'M' ? 'his' : 'her') . ' twin ' .
2844
						(($sibling->sex() eq 'F') ? 'sister ' : 'brother ') .
2845
						$sibling->given_names() . ',';
2846
				}
2847
			}
2848
2849
			if(scalar(@spouses) && ($numberofchildren > 0) && !$all_children_are_alive) {
2850
				# $bio .= ' and';
2851
			} else {
2852
				$bio .= '.';
2853
				$end_of_sentence = 1;
2854
			}
2855
		} elsif($dateofbaptism || $placeofbaptism) {
2856
			$bio .= " $pronoun was ";
2857
2858
			if($ENV{'LANG'} =~ /^en_US/) {
2859
				$bio .= 'baptized';
2860
			} else {
2861
				$bio .= 'baptised';
2862
			}
2863
			if($placeofbaptism) {
2864
				if($placeofbirth && ($placeofbaptism eq $placeofbirth)) {
2865
					$bio .= ' there';
2866
					if(my $address = $baptism->address()) {
2867
						$bio .= " at $address";
2868
					}
2869
				} else {
2870
					my $opts = {
2871
						person => $person,
2872
						place => $placeofbaptism,
2873
						places_printed => \%places_printed
2874
					};
2875
					if(my $address = $baptism->address()) {
2876
						$opts->{'address'} = $address;
2877
					}
2878
					my $p = place($opts);
2879
					$bio .= $p;
2880
					$places_printed{$p} = 1;
2881
				}
2882
			}
2883
			if($dateofbaptism) {
2884
				$bio .= ' ' . year({
2885
					person => $person,
2886
					date => $dateofbaptism,
2887
					must_postdate => $birth_dt,
2888
					must_predate => $death_dt
2889
				}) . sibling_baptism_string({
2890
					person => $person,
2891
					siblings => \@siblings,
2892
					date => $dateofbaptism,
2893
					birthdate => $dateofbirth,
2894
				});
2895
			}
2896
			if(scalar(@spouses)) {
2897
				if(!scalar(@residences)) {
2898
					$bio .= ',';
2899
				}
2900
				$end_of_sentence = 0;
2901
			} else {
2902
				$bio .= '.';
2903
				$end_of_sentence = 1;
2904
			}
2905
		}
2906
2907
		# Is/was this person an orphan?
2908
		if($mother && $father && $yob) {
2909
			if((my $mdod = dateofdeath($mother)) &&
2910
			   (my $fdod = dateofdeath($father))) {
2911
				my $myod;
2912
				my $fyod;
2913
				if(($fdod =~ /.*?(\d{3,4})/)) {
2914
					$fyod = $1;
2915
				}
2916
				if(($mdod =~ /.*?(\d{3,4})/)) {
2917
					$myod = $1;
2918
				}
2919
				if((!defined($fyod)) || (!defined($myod))) {
2920
					die "BUG: !fyod || !myod";
2921
				}
2922
				if((($fyod - $yob) < 16) && (($myod - $yob) < 16)) {
2923
					if($end_of_sentence) {
2924
						$bio .= " $pronoun";
2925
					} elsif(scalar(@person_twins)) {
2926
						$bio .= ' and';
2927
					} else {
2928
						$bio .= ', and';
2929
					}
2930
					$bio .= ' was orphaned ';
2931
					my $orphaned_year = (($myod > $fyod) ? $myod : $fyod);
2932
					if($myod == $fyod) {
2933
						$bio .= "in $myod by the death of both parents in that year.";
2934
					} elsif($myod > $fyod) {
2935
						$bio .= 'at the age of ' . ($myod - $yob) .
2936
							' following the death of ' .
2937
							(($person->pronoun() eq 'She') ? 'her' : 'his') .
2938
							" father in $fyod and mother in $myod. ";
2939
					} else {
2940
						$bio .= 'at the age of ' . ($fyod - $yob) .
2941
							' following the death of ' .
2942
							(($person->pronoun() eq 'She') ? 'her' : 'his') .
2943
							" mother in $myod and father in $fyod. ";
2944
					}
2945
					$bio .= "</p><p>";
2946
					$end_of_sentence = 1;
2947
					$start_of_paragraph = 1;
2948
2949
					print $xml "\n\t\t<orphaned>$orphaned_year</orphaned>";
2950
					push @{$orphans{$orphaned_year}}, $person->xref();
2951
				}
2952
			}
2953
		}
2954
2955
		print "bio so far: $bio\n" if($opts{'v'});
2956
2957
		my @education = $person->education();
2958
2959
		if(scalar(@education)) {
2960
			if($end_of_sentence) {
2961
				$bio .= " $pronoun";
2962
			}
2963
			# FIXME: do all schools
2964
			$bio .= ' went to'.
2965
				place({ person => $person, record => $education[0], places_printed => \%places_printed, nopreposition => 1 }) .
2966
				'. ';
2967
			$end_of_sentence = 1;
2968
		}
2969
2970
		# TODO: children != 0 && spouses == 0
2971
		if(scalar(@spouses) &&
2972
		   ((!$spouserelationship) || $placeofmarriage || $dateofmarriage)) {
2973
			$bio .= " $pronoun" if($end_of_sentence);
2974
2975
			if(scalar(@spouses) == 1) {
2976
				if((!$end_of_sentence) &&
2977
				   ($dateofbirth || $dateofdeath) &&
2978
				   ((scalar(@residences) > 0) || ((!($dateofbaptism)) && !$placeofbaptism))) {
2979
					$bio .= ' and';
2980
				}
2981
				if($placeofmarriage || $dateofmarriage) {
2982
					if($placeofbaptism && $placeofmarriage && ($placeofmarriage eq $placeofbaptism) &&
2983
					   !$end_of_sentence) {
2984
						$bio .= ' also';
2985
					}
2986
					$bio .= ' married ';
2987
				} else {
2988
					$bio .= ' was married to ';
2989
				}
2990
				if($haveprintedspousename) {
2991
					$nameparser->parse($spouses[0]->name());
2992
2993
					my %name_components = $nameparser->components();
2994
					if(my $n = $name_components{'given_name_1'}) {
2995
						$bio .= $n;
2996
					} else {
2997
						complain({ person => $spouses[0], warning => 'seems to have no first name' });
2998
					}
2999
				} else {
3000
					$html_and_csv->print($bio);
3001
					$bio =~ s/&/&amp;/g;
3002
					$bio =~ s/</&lt;/g;
3003
					$bio =~ s/>/&gt;/g;
3004
					$bio =~ s/&amp;amp;/&amp;/g;	# Because of the Encode entities
3005
					print $xml $bio;
3006
3007
					$fullbio .= $bio . $spouses[0]->as_string();
3008
					$bio = '';
3009
3010
					if($opts{'l'} || !$is_alive) {
3011
						print $html '<a href="', make_filename_from_person(person => $spouses[0]), '">',
3012
							$spouses[0]->as_string(),
3013
							'</a>';
3014
						print $csv '<a href="?page=people&entry=', $spouses[0]->xref(), '">',
3015
							$spouses[0]->as_string(),
3016
							'</a>';
3017
						print $xml '&lt;a href="?page=people&amp;entry=', $spouses[0]->xref(), '"&gt;',
3018
							$spouses[0]->as_string(),
3019
							'&lt;/a&gt;';
3020
					} else {
3021
						print $html '<a href="', make_filename_from_person(person => $spouses[0]), '">',
3022
							$spouses[0]->given_names(),
3023
							'</a>';
3024
						print $csv '<a href="?page=people&entry=', $spouses[0]->xref(), '">',
3025
							$spouses[0]->given_names(),
3026
							'</a>';
3027
						print $xml '&lt;a href="?page=people&amp;entry=', $spouses[0]->xref(), '"&gt;',
3028
							$spouses[0]->given_names(),
3029
							'&lt;/a&gt;';
3030
					}
3031
					$haveprintedspousename = 1;
3032
				}
3033
				my $parentheses = 0;
3034
				if($numberofchildren) {
3035
					# if((!$placeofmarriage) && !$dateofmarriage) {
3036
						# $bio .= ', ';
3037
					# }
3038
					my @spouse_occupations = get_all_occupations($spouses[0]);
3039
					if(my $soccupation = $spouse_occupations[0]) {
3040
						$parentheses = 1;
3041
						if($language eq 'English') {
3042
							$bio .= ' (' . Lingua::EN::Inflect::A(lc($soccupation)) . ' ';
3043
						} else {
3044
							# FIXME - handle feminine versions for women
3045
							$bio .= ' (un ' . lc($soccupation) . ' ';
3046
						}
3047
					}
3048
					my @childrenofthisspouse;
3049
					my $numberofchildrenwiththisspouse = $numberofchildren;
3050
					my $spouse = $spouses[0];
3051
					foreach my $child(@children) {
3052
						if($sex eq 'F') {
3053
							# Check through all possible fathers, since there could be a biologial and
3054
							# and adoptive one listed
3055
							# FIXME: this assumes that the spouse is the biological father, which is not
3056
							#	a good assumption to make
3057
							my @candidates = $child->father();
3058
							my $father;