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