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