File Coverage

blib/lib/Genealogy/Wills.pm
Criterion Covered Total %
statement 39 52 75.0
branch 8 14 57.1
condition 2 8 25.0
subroutine 9 9 100.0
pod 2 2 100.0
total 60 85 70.5


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