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