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