File Coverage

blib/lib/Genealogy/Wills.pm
Criterion Covered Total %
statement 35 49 71.4
branch 6 12 50.0
condition 3 9 33.3
subroutine 9 9 100.0
pod 2 2 100.0
total 55 81 67.9


line stmt bran cond sub pod time code
1             package Genealogy::Wills;
2              
3 4     4   497754 use warnings;
  4         36  
  4         129  
4 4     4   29 use strict;
  4         8  
  4         70  
5 4     4   19 use Carp;
  4         7  
  4         193  
6 4     4   22 use File::Spec;
  4         13  
  4         123  
7 4     4   2110 use Module::Info;
  4         27759  
  4         119  
8 4     4   2085 use Genealogy::Wills::DB;
  4         15  
  4         147  
9 4     4   1744 use Genealogy::Wills::DB::wills;
  4         9  
  4         1602  
10              
11             =head1 NAME
12              
13             Genealogy::Wills - Lookup in a database of wills
14              
15             =head1 VERSION
16              
17             Version 0.02
18              
19             =cut
20              
21             our $VERSION = '0.02';
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 3     3 1 2976 my($proto, %args) = @_;
42 3   66     25 my $class = ref($proto) || $proto;
43              
44 3 100       17 if(!defined($class)) {
    50          
45             # Using Genealogy::Wills->new(), not Genealogy::Wills::new()
46             # carp(__PACKAGE__, ' use ->new() not ::new() to instantiate');
47             # return;
48              
49             # FIXME: this only works when no arguments are given
50 1         2 $class = __PACKAGE__;
51             } elsif(ref($class)) {
52             # clone the given object
53 0         0 return bless { %{$class}, %args }, ref($class);
  0         0  
54             }
55              
56 3   33     24 my $directory = $args{'directory'} || Module::Info->new_from_loaded(__PACKAGE__)->file();
57 3         452 $directory =~ s/\.pm$//;
58              
59 3         123 Genealogy::Wills::DB::init(directory => File::Spec->catfile($directory, 'database'), %args);
60 3         19 return bless { }, $class;
61             }
62              
63             =head2 search
64              
65             my $wills = Genealogy::Wills->new();
66              
67             # Returns an array of hashrefs
68             my @smiths = $wills->search(last => 'Smith'); # You must at least define the last name to search for
69              
70             print $smiths[0]->{'first'}, "\n";
71              
72             =cut
73              
74             sub search {
75 3     3 1 850 my $self = shift;
76              
77 3 100       11 my %params = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
  1         5  
78              
79 3 50       11 if(!defined($params{'last'})) {
80 3         10 Carp::carp("Value for 'last' is mandatory");
81 3         1026 return;
82             }
83              
84 0   0       $self->{'wills'} ||= Genealogy::Wills::DB::wills->new(no_entry => 1);
85              
86 0 0         if(!defined($self->{'wills'})) {
87 0           Carp::croak("Can't open the wills database");
88             }
89              
90 0 0         if(wantarray) {
91 0           my @wills = @{$self->{'wills'}->selectall_hashref(\%params)};
  0            
92 0           foreach my $will(@wills) {
93 0           $will->{'url'} = 'https://' . $will->{'url'};
94             }
95 0           return @wills;
96             }
97 0           my $will = $self->{'wills'}->fetchrow_hashref(\%params);
98 0           $will->{'url'} = 'https://' . $will->{'url'};
99 0           return $will;
100             }
101              
102             =head1 AUTHOR
103              
104             Nigel Horne, C<< >>
105              
106             =head1 BUGS
107              
108             =head1 SEE ALSO
109              
110             The Kent Wills Transcript, L
111              
112             =head1 SUPPORT
113              
114             You can find documentation for this module with the perldoc command.
115              
116             perldoc Genealogy::Wills
117              
118             You can also look for information at:
119              
120             =over 4
121              
122             =item * MetaCPAN
123              
124             L
125              
126             =item * RT: CPAN's request tracker
127              
128             L
129              
130             =item * CPANTS
131              
132             L
133              
134             =item * CPAN Testers' Matrix
135              
136             L
137              
138             =item * CPAN Ratings
139              
140             L
141              
142             =item * CPAN Testers Dependencies
143              
144             L
145              
146             =back
147              
148             =head1 LICENSE AND COPYRIGHT
149              
150             Copyright 2023 Nigel Horne.
151              
152             This program is released under the following licence: GPL2
153              
154             =cut
155              
156             1;