File Coverage

blib/lib/Genealogy/Wills.pm
Criterion Covered Total %
statement 28 46 60.8
branch 2 10 20.0
condition 3 9 33.3
subroutine 8 9 88.8
pod 2 2 100.0
total 43 76 56.5


line stmt bran cond sub pod time code
1             package Genealogy::Wills;
2              
3 3     3   387594 use warnings;
  3         25  
  3         140  
4 3     3   16 use strict;
  3         7  
  3         82  
5 3     3   16 use Carp;
  3         5  
  3         156  
6 3     3   15 use File::Spec;
  3         6  
  3         80  
7 3     3   1649 use Module::Info;
  3         21779  
  3         92  
8 3     3   1611 use Genealogy::Wills::DB;
  3         10  
  3         121  
9 3     3   1425 use Genealogy::Wills::DB::wills;
  3         8  
  3         1167  
10              
11             =head1 NAME
12              
13             Genealogy::Wills - Lookup in a database of wills
14              
15             =head1 VERSION
16              
17             Version 0.01
18              
19             =cut
20              
21             our $VERSION = '0.01';
22              
23             =head1 SYNOPSIS
24              
25             # See https://freepages.rootsweb.com/~mrawson/genealogy/wills.html
26             use Genealogy::Wills;
27             my $wills = Genealogy::Wills->new();
28             # ...
29              
30             =head1 SUBROUTINES/METHODS
31              
32             =head2 new
33              
34             Creates a Genealogy::Wills object.
35              
36             Takes an optional argument, directory, that is the directory containing wills.sql.
37              
38             =cut
39              
40             sub new {
41 2     2 1 89 my($proto, %param) = @_;
42 2   66     12 my $class = ref($proto) || $proto;
43              
44             # Use Genealogy::Wills->new, not Genealogy::Wills::new
45 2 100       8 return unless($class);
46              
47 1   33     9 my $directory = $param{'directory'} || Module::Info->new_from_loaded(__PACKAGE__)->file();
48 1         189 $directory =~ s/\.pm$//;
49              
50 1         47 Genealogy::Wills::DB::init(directory => File::Spec->catfile($directory, 'database'), %param);
51 1         10 return bless { }, $class;
52             }
53              
54             =head2 search
55              
56             my $wills = Genealogy::Wills->new();
57              
58             # Returns an array of hashrefs
59             my @smiths = $wills->search(last => 'Smith'); # You must at least define the last name to search for
60              
61             print $smiths[0]->{'first'}, "\n";
62              
63             =cut
64              
65             sub search {
66 0     0 1   my $self = shift;
67              
68 0 0         my %params = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
  0            
69              
70 0 0         if(!defined($params{'last'})) {
71 0           Carp::carp("Value for 'last' is mandatory");
72 0           return;
73             }
74              
75 0   0       $self->{'wills'} ||= Genealogy::Wills::DB::wills->new(no_entry => 1);
76              
77 0 0         if(!defined($self->{'wills'})) {
78 0           Carp::croak("Can't open the wills database");
79             }
80              
81 0 0         if(wantarray) {
82 0           my @wills = @{$self->{'wills'}->selectall_hashref(\%params)};
  0            
83 0           foreach my $will(@wills) {
84 0           $will->{'url'} = 'https://' . $will->{'url'};
85             }
86 0           return @wills;
87             }
88 0           my $will = $self->{'wills'}->fetchrow_hashref(\%params);
89 0           $will->{'url'} = 'https://' . $will->{'url'};
90 0           return $will;
91             }
92              
93             =head1 AUTHOR
94              
95             Nigel Horne, C<< >>
96              
97             =head1 BUGS
98              
99             =head1 SEE ALSO
100              
101             The Kent Wills Transcript, L
102              
103             =head1 SUPPORT
104              
105             You can find documentation for this module with the perldoc command.
106              
107             perldoc Genealogy::Wills
108              
109             You can also look for information at:
110              
111             =over 4
112              
113             =item * MetaCPAN
114              
115             L
116              
117             =item * RT: CPAN's request tracker
118              
119             L
120              
121             =item * CPANTS
122              
123             L
124              
125             =item * CPAN Testers' Matrix
126              
127             L
128              
129             =item * CPAN Ratings
130              
131             L
132              
133             =item * CPAN Testers Dependencies
134              
135             L
136              
137             =back
138              
139             =head1 LICENSE AND COPYRIGHT
140              
141             Copyright 2023 Nigel Horne.
142              
143             This program is released under the following licence: GPL2
144              
145             =cut
146              
147             1;