view release on metacpan or  search on metacpan

bin/create_db.PL  view on Meta::CPAN

		   ($warning =~ /isn't numeric in numeric eq /i)) {
			die $warning;
		}
		warn $warning;
	}
}

my $force_flag;
my $dir  = 'lib/Genealogy/Wills/data';
my $bdir = File::Spec->catdir('blib', $dir);

if(defined($ARGV[0]) && ($ARGV[0] eq '-f')) {
	$force_flag++;
} elsif($ENV{'AUTOMATED_TESTING'}) {
	if(!-d $dir) {
		mkdir $dir, 0755;
	}
	exit;
}

if(!-d $dir) {
	mkdir $dir, 0755;
}

my $filename = File::Spec->catdir($dir, 'wills.sql');

if(-r $filename) {
	# Don't bother downloading if the file is less than a day old
	if(((-s $filename) > 0) && (-M $filename < 1) && !$force_flag) {
		_sync_to_blib();
		exit;
	}
	unlink $filename;
}

# $ENV{CACHE_DIR}/$ENV{CACHEDIR} is external input: validate before use in
# file operations. A tainted or attacker-controlled path (e.g. ../../etc)
# could cause mkdir or HTTP::Cache::Transparent to write outside the
# intended cache tree. Only allow safe filesystem characters and reject
# path traversal sequences.
my $cache_dir_raw = $ENV{'CACHE_DIR'} // $ENV{'CACHEDIR'};
my $cache_dir;
if(defined $cache_dir_raw) {
	unless($cache_dir_raw =~ /\A[\w.\-\/~]+\z/ && index($cache_dir_raw, '..') < 0) {
		Carp::croak("Unsafe cache directory path in CACHE_DIR/CACHEDIR: $cache_dir_raw");
	}
	$cache_dir = $cache_dir_raw;
	mkdir $cache_dir, 0700 if(!-d $cache_dir);
	$cache_dir = File::Spec->catfile($cache_dir, 'http-cache-transparent');
} else {
	$cache_dir = File::Spec->catfile(File::HomeDir->my_home(), '.cache', 'http-cache-transparent');
}

HTTP::Cache::Transparent::init({
	BasePath => $cache_dir,
	Verbose  => 0,
	NoUpdate => 60 * 60 * 24 * 7 * 31,	# The archive never changes
	MaxAge   => 30 * 24
}) || Carp::croak("$0: $cache_dir: $!");

my $ua = LWP::UserAgent::WithCache->new(timeout => 10, keep_alive => 1);
$ua->env_proxy(1);
$ua->agent('Genealogy::Wills');
# $ua->agent('Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/125.0.0.0 Safari/537.36');
$ua->conn_cache()->total_capacity(undef);
$Lingua::EN::NameCase::POSTNOMINAL = 0;

# RaiseError => 1 means DBI throws on failure before ever returning undef
my $dbh = DBI->connect("dbi:SQLite:dbname=$filename", undef, undef, { RaiseError => 1, AutoCommit => 0, synchronous => 0, locking_mode => 'EXCLUSIVE' });

$dbh->do('PRAGMA cache_size = -65536');	# 64MB
$dbh->do('PRAGMA journal_mode = OFF');
$dbh->do('CREATE TABLE wills(first VARCHAR NOT NULL, middle VARCHAR, last VARCHAR NOT NULL, town VARCHAR, year INTEGER, url VARCHAR)');

my @queue;
foreach my $page ('ab', 'c', 'dg', 'hj', 'km', 'nr', 'sv', 'wy') {
	mrawson($ua, $page);
	flush($dbh) if(scalar(@queue) > 200_000);
};

print ' ' x 78, "\r";

flush($dbh);

$dbh->commit();
$dbh->prepare('CREATE INDEX name_index ON wills(first, last)')->execute();
$dbh->prepare('CREATE INDEX name_index_year ON wills(first, last, year)')->execute();
$dbh->do('pragma optimize');
$dbh->disconnect();

print "\n";

_sync_to_blib();

sub _sync_to_blib {
	mkdir $bdir, 0755 unless -d $bdir;
	return unless -d $bdir && -r $filename;
	my $bfilename = File::Spec->catdir($bdir, 'wills.sql');
	unlink $bfilename if -e $bfilename;
	link $filename, $bfilename;
}

sub mrawson {
	my ($ua, $page) = @_;

	my $url = "https://freepages.rootsweb.com/~mrawson/genealogy/will_$page.html";

	# local $| flushes immediately and restores on scope exit
	local $| = 1;
	printf "%-70s\r", $url;

	my $response = $ua->get($url);

	my $data;
	if($response->is_success) {
		$data = $response->decoded_content();
	} else {
		# status_line() comes from the upstream server; concatenate (not
		# comma-list) to form one string before passing to Carp::croak.
		Carp::croak("\n$url: " . $response->status_line());
	}