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