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