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