File Coverage

blib/lib/Genealogy/Wills/DB.pm
Criterion Covered Total %
statement 31 308 10.0
branch 1 174 0.5
condition 3 80 3.7
subroutine 10 20 50.0
pod 0 8 0.0
total 45 590 7.6


line stmt bran cond sub pod time code
1             package Genealogy::Wills::DB;
2              
3             =head1
4              
5             Genealogy::Wills::DB
6              
7             =cut
8              
9             # Author Nigel Horne: njh@bandsman.co.uk
10             # Copyright (C) 2023, Nigel Horne
11              
12             # Usage is subject to licence terms.
13             # The licence terms of this software are as follows:
14             # Personal single user, single computer use: GPL2
15             # All other users (including Commercial, Charity, Educational, Government)
16             # must apply in writing for a licence for use from Nigel Horne at the
17             # above e-mail.
18              
19             # Abstract class giving read-only access to CSV, XML and SQLite databases via Perl without writing any SQL.
20             # Look for databases in $directory in this order;
21             # SQLite (file ends with .sql)
22             # PSV (pipe separated file, file ends with .psv)
23             # CSV (file ends with .csv or .db, can be gzipped)
24             # XML (file ends with .xml)
25              
26             # For example, you can access the files in /var/db/foo.csv via this class:
27              
28             # package MyPackageName::DB::foo;
29              
30             # use NJH::Snippets::DB;
31              
32             # our @ISA = ('NJH::Snippets::DB');
33              
34             # 1;
35              
36             # You can then access the data using:
37             # my $foo = MyPackageName::DB::foo->new(directory => '/var/db');
38             # my $row = $foo->fetchrow_hashref(customer_id => '12345);
39             # print Data::Dumper->new([$row])->Dump();
40              
41             # CSV files can have empty lines of comment lines starting with '#', to make them more readable
42              
43             # If the table has a column called "entry", sorts are based on that
44             # To turn that off, pass 'no_entry' to the constructor, for legacy
45             # reasons it's enabled by default
46             # TODO: Switch that to off by default, and enable by passing 'entry'
47              
48             # TODO: support a directory hierarchy of databases
49             # TODO: consider returning an object or array of objects, rather than hashes
50             # TODO: Add redis database - could be of use for Geo::Coder::Free
51             # use select() to select a database - use the table arg
52             # new(database => 'redis://servername');
53              
54 3     3   22 use warnings;
  3         6  
  3         113  
55 3     3   16 use strict;
  3         7  
  3         76  
56              
57 3     3   1699 use DBD::SQLite::Constants qw/:file_open/; # For SQLITE_OPEN_READONLY
  3         99754  
  3         799  
58 3     3   29 use File::Basename;
  3         6  
  3         253  
59 3     3   25 use File::Spec;
  3         7  
  3         120  
60 3     3   1422 use File::pfopen 0.02;
  3         1791  
  3         149  
61 3     3   2703 use File::Temp;
  3         63054  
  3         225  
62 3     3   1446 use Error::Simple;
  3         14059  
  3         33  
63 3     3   154 use Carp;
  3         6  
  3         10788  
64              
65             our $directory;
66             our $logger;
67             our $cache;
68              
69             sub new {
70 0     0 0 0 my $proto = shift;
71 0 0       0 my %args = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
  0         0  
72              
73 0   0     0 my $class = ref($proto) || $proto;
74              
75 0 0       0 if($class eq __PACKAGE__) {
76 0         0 die "$class: abstract class";
77             }
78              
79 0 0 0     0 die "$class: where are the files?" unless($directory || $args{'directory'});
80             # init(\%args);
81              
82             return bless {
83             logger => $args{'logger'} || $logger,
84             directory => $args{'directory'} || $directory, # The directory containing the tables in XML, SQLite or CSV format
85             cache => $args{'cache'} || $cache,
86             table => $args{'table'}, # The name of the file containing the table, defaults to the class name
87 0   0     0 no_entry => $args{'no_entry'} || 0,
      0        
      0        
      0        
88             }, $class;
89             }
90              
91             # Can also be run as a class level __PACKAGE__::DB::init(directory => '../databases')
92             sub init {
93 1 50   1 0 8 my %args = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
  0         0  
94              
95 1   33     7 $directory ||= $args{'directory'};
96 1   33     7 $logger ||= $args{'logger'};
97 1   33     6 $cache ||= $args{'cache'};
98             }
99              
100             sub set_logger {
101 0     0 0   my $self = shift;
102              
103 0           my %args;
104              
105 0 0         if(ref($_[0]) eq 'HASH') {
    0          
    0          
106 0           %args = %{$_[0]};
  0            
107             } elsif(!ref($_[0])) {
108 0           Carp::croak('Usage: set_logger(logger => $logger)');
109             } elsif(scalar(@_) % 2 == 0) {
110 0           %args = @_;
111             } else {
112 0           $args{'logger'} = shift;
113             }
114              
115 0           $self->{'logger'} = $args{'logger'};
116              
117 0           return $self;
118             }
119              
120             # Open the database.
121              
122             sub _open {
123 0     0     my $self = shift;
124             my %args = (
125             sep_char => '!',
126 0 0         ((ref($_[0]) eq 'HASH') ? %{$_[0]} : @_)
  0            
127             );
128              
129 0   0       my $table = $self->{'table'} || ref($self);
130 0           $table =~ s/.*:://;
131              
132 0 0         if($self->{'logger'}) {
133 0           $self->{'logger'}->trace("_open $table");
134             }
135 0 0         return if($self->{$table});
136              
137             # Read in the database
138 0           my $dbh;
139              
140 0   0       my $dir = $self->{'directory'} || $directory;
141 0           my $slurp_file = File::Spec->catfile($dir, "$table.sql");
142 0 0         if($self->{'logger'}) {
143 0           $self->{'logger'}->debug("_open: try to open $slurp_file");
144             }
145              
146 0 0         if(-r $slurp_file) {
147 0           require DBI;
148              
149 0           DBI->import();
150              
151 0           $dbh = DBI->connect("dbi:SQLite:dbname=$slurp_file", undef, undef, {
152             sqlite_open_flags => SQLITE_OPEN_READONLY,
153             });
154 0           $dbh->do('PRAGMA synchronous = OFF');
155 0           $dbh->do('PRAGMA cache_size = 65536');
156 0 0         if($self->{'logger'}) {
157 0           $self->{'logger'}->debug("read in $table from SQLite $slurp_file");
158             }
159 0           $self->{'type'} = 'DBI';
160             } else {
161 0           my $fin;
162 0           ($fin, $slurp_file) = File::pfopen::pfopen($dir, $table, 'csv.gz:db.gz');
163 0 0 0       if(defined($slurp_file) && (-r $slurp_file)) {
164 0           require Gzip::Faster;
165 0           Gzip::Faster->import();
166              
167 0           close($fin);
168 0           $fin = File::Temp->new(SUFFIX => '.csv', UNLINK => 0);
169 0           print $fin gunzip_file($slurp_file);
170 0           $slurp_file = $fin->filename();
171 0           $self->{'temp'} = $slurp_file;
172             } else {
173 0           ($fin, $slurp_file) = File::pfopen::pfopen($dir, $table, 'psv');
174 0 0         if(defined($fin)) {
175             # Pipe separated file
176 0           $args{'sep_char'} = '|';
177             } else {
178 0           ($fin, $slurp_file) = File::pfopen::pfopen($dir, $table, 'csv:db');
179             }
180             }
181 0 0 0       if(defined($slurp_file) && (-r $slurp_file)) {
182 0           close($fin);
183 0           my $sep_char = $args{'sep_char'};
184 0 0         if($args{'column_names'}) {
185             $dbh = DBI->connect("dbi:CSV:csv_sep_char=$sep_char", undef, undef,
186             {
187             csv_tables => {
188             $table => {
189 0           col_names => $args{'column_names'},
190             },
191             },
192             }
193             );
194             } else {
195 0           $dbh = DBI->connect("dbi:CSV:csv_sep_char=$sep_char");
196             }
197 0           $dbh->{'RaiseError'} = 1;
198              
199 0 0         if($self->{'logger'}) {
200 0           $self->{'logger'}->debug("read in $table from CSV $slurp_file");
201             }
202              
203 0           $dbh->{csv_tables}->{$table} = {
204             allow_loose_quotes => 1,
205             blank_is_undef => 1,
206             empty_is_undef => 1,
207             binary => 1,
208             f_file => $slurp_file,
209             escape_char => '\\',
210             sep_char => $sep_char,
211             # Don't do this, causes "Bizarre copy of HASH
212             # in scalar assignment in error_diag
213             # RT121127
214             # auto_diag => 1,
215             auto_diag => 0,
216             # Don't do this, it causes "Attempt to free unreferenced scalar"
217             # callbacks => {
218             # after_parse => sub {
219             # my ($csv, @rows) = @_;
220             # my @rc;
221             # foreach my $row(@rows) {
222             # if($row->[0] !~ /^#/) {
223             # push @rc, $row;
224             # }
225             # }
226             # return @rc;
227             # }
228             # }
229             };
230              
231             # my %options = (
232             # allow_loose_quotes => 1,
233             # blank_is_undef => 1,
234             # empty_is_undef => 1,
235             # binary => 1,
236             # f_file => $slurp_file,
237             # escape_char => '\\',
238             # sep_char => $sep_char,
239             # );
240              
241             # $dbh->{csv_tables}->{$table} = \%options;
242             # delete $options{f_file};
243              
244             # require Text::CSV::Slurp;
245             # Text::CSV::Slurp->import();
246             # $self->{'data'} = Text::CSV::Slurp->load(file => $slurp_file, %options);
247              
248 0           if(0) {
249             require Text::xSV::Slurp;
250             Text::xSV::Slurp->import();
251              
252             my @data = @{xsv_slurp(
253             shape => 'aoh',
254             text_csv => {
255             sep_char => $sep_char,
256             allow_loose_quotes => 1,
257             blank_is_undef => 1,
258             empty_is_undef => 1,
259             binary => 1,
260             escape_char => '\\',
261             },
262             # string => \join('', grep(!/^\s*(#|$)/, ))
263             file => $slurp_file
264             )};
265              
266             # Ignore blank lines or lines starting with # in the CSV file
267             unless($self->{no_entry}) {
268             @data = grep { $_->{'entry'} !~ /^\s*#/ } grep { defined($_->{'entry'}) } @data;
269             }
270             # $self->{'data'} = @data;
271             my $i = 0;
272             $self->{'data'} = ();
273             foreach my $d(@data) {
274             $self->{'data'}[$i++] = $d;
275             }
276             }
277 0           $self->{'type'} = 'CSV';
278             } else {
279 0           $slurp_file = File::Spec->catfile($dir, "$table.xml");
280 0 0         if(-r $slurp_file) {
281 0           $dbh = DBI->connect('dbi:XMLSimple(RaiseError=>1):');
282 0           $dbh->{'RaiseError'} = 1;
283 0 0         if($self->{'logger'}) {
284 0           $self->{'logger'}->debug("read in $table from XML $slurp_file");
285             }
286 0           $dbh->func($table, 'XML', $slurp_file, 'xmlsimple_import');
287             } else {
288 0           my @call_details = caller(0);
289 0           throw Error::Simple("Can't open $slurp_file called from " .
290             $call_details[2] . ' of ' . $call_details[1]);
291             }
292 0           $self->{'type'} = 'XML';
293             }
294             }
295              
296 0           $self->{$table} = $dbh;
297 0           my @statb = stat($slurp_file);
298 0           $self->{'_updated'} = $statb[9];
299              
300 0           return $self;
301             }
302              
303             # Returns a reference to an array of hash references of all the data meeting
304             # the given criteria
305             sub selectall_hashref {
306 0     0 0   my $self = shift;
307 0           my @rc = $self->selectall_hash(@_);
308 0           return \@rc;
309             }
310              
311             # Returns an array of hash references
312             sub selectall_hash {
313 0     0 0   my $self = shift;
314 0 0         my %params = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
  0            
315              
316 0   0       my $table = $self->{table} || ref($self);
317 0           $table =~ s/.*:://;
318              
319 0 0         $self->_open() if(!$self->{$table});
320              
321 0 0 0       if((scalar(keys %params) == 0) && $self->{'data'}) {
322 0 0         if($self->{'logger'}) {
323 0           $self->{'logger'}->trace("$table: selectall_hash fast track return");
324             }
325             # This use of a temporary variable is to avoid
326             # "Implicit scalar context for array in return"
327             # return @{$self->{'data'}};
328 0           my @rc = @{$self->{'data'}};
  0            
329 0           return @rc;
330             }
331             # if((scalar(keys %params) == 1) && $self->{'data'} && defined($params{'entry'})) {
332             # }
333              
334 0           my $query;
335 0           my $done_where = 0;
336 0 0 0       if(($self->{'type'} eq 'CSV') && !$self->{no_entry}) {
337 0           $query = "SELECT * FROM $table WHERE entry IS NOT NULL AND entry NOT LIKE '#%'";
338 0           $done_where = 1;
339             } else {
340 0           $query = "SELECT * FROM $table";
341             }
342 0           my @query_args;
343 0           foreach my $c1(sort keys(%params)) { # sort so that the key is always the same
344 0           my $arg = $params{$c1};
345 0 0         if(ref($arg)) {
346 0 0         if($self->{'logger'}) {
347 0           $self->{'logger'}->fatal("selectall_hash $query: argument is not a string");
348             }
349 0           throw Error::Simple("$query: argument is not a string");
350             }
351 0 0         if(!defined($arg)) {
352 0           my @call_details = caller(0);
353 0           throw Error::Simple("$query: value for $c1 is not defined in call from " .
354             $call_details[2] . ' of ' . $call_details[1]);
355             }
356 0 0         if($done_where) {
357 0 0         if($arg =~ /\@/) {
358 0           $query .= " AND $c1 LIKE ?";
359             } else {
360 0           $query .= " AND $c1 = ?";
361             }
362             } else {
363 0 0         if($arg =~ /\@/) {
364 0           $query .= " WHERE $c1 LIKE ?";
365             } else {
366 0           $query .= " WHERE $c1 = ?";
367             }
368 0           $done_where = 1;
369             }
370 0           push @query_args, $arg;
371             }
372 0 0         if(!$self->{no_entry}) {
373 0           $query .= ' ORDER BY entry';
374             }
375 0 0         if(!wantarray) {
376 0           $query .= ' LIMIT 1';
377             }
378 0 0         if($self->{'logger'}) {
379 0 0         if(defined($query_args[0])) {
380 0           $self->{'logger'}->debug("selectall_hash $query: ", join(', ', @query_args));
381             } else {
382 0           $self->{'logger'}->debug("selectall_hash $query");
383             }
384             }
385 0           my $key;
386             my $c;
387 0 0         if($c = $self->{cache}) {
388 0           $key = $query;
389 0 0         if(defined($query_args[0])) {
390 0           $key .= ' ' . join(', ', @query_args);
391             }
392 0 0         if(my $rc = $c->get($key)) {
393             # This use of a temporary variable is to avoid
394             # "Implicit scalar context for array in return"
395             # return @{$rc};
396 0           my @rc = @{$rc};
  0            
397 0           return @rc;
398             }
399             }
400              
401 0 0         if(my $sth = $self->{$table}->prepare($query)) {
402 0 0         $sth->execute(@query_args) ||
403             throw Error::Simple("$query: @query_args");
404              
405 0           my @rc;
406 0           while(my $href = $sth->fetchrow_hashref()) {
407             # FIXME: Doesn't store in the cache
408 0 0         return $href if(!wantarray);
409 0           push @rc, $href;
410             }
411 0 0 0       if($c && wantarray) {
412 0           $c->set($key, \@rc, '1 hour');
413             }
414              
415 0           return @rc;
416             }
417 0 0         if($self->{'logger'}) {
418 0           $self->{'logger'}->warn("selectall_hash failure on $query: @query_args");
419             }
420 0           throw Error::Simple("$query: @query_args");
421             }
422              
423             # Returns a hash reference for one row in a table
424             # Special argument: table: determines the table to read from if not the default,
425             # which is worked out from the class name
426             sub fetchrow_hashref {
427 0     0 0   my $self = shift;
428 0 0         my %params = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
  0            
429              
430 0   0       my $table = $self->{'table'} || ref($self);
431 0           $table =~ s/.*:://;
432              
433 0 0         $self->_open() if(!$self->{$table});
434              
435 0           my $query = 'SELECT * FROM ';
436 0 0         if(my $t = delete $params{'table'}) {
437 0           $query .= $t;
438             } else {
439 0           $query .= $table;
440             }
441 0           my $done_where = 0;
442 0 0 0       if(($self->{'type'} eq 'CSV') && !$self->{no_entry}) {
443 0           $query .= " WHERE entry IS NOT NULL AND entry NOT LIKE '#%'";
444 0           $done_where = 1;
445             }
446 0           my @query_args;
447 0           foreach my $c1(sort keys(%params)) { # sort so that the key is always the same
448 0 0         if(my $arg = $params{$c1}) {
449 0 0         if($done_where) {
450 0 0         if($arg =~ /\@/) {
451 0           $query .= " AND $c1 LIKE ?";
452             } else {
453 0           $query .= " AND $c1 = ?";
454             }
455             } else {
456 0 0         if($arg =~ /\@/) {
457 0           $query .= " WHERE $c1 LIKE ?";
458             } else {
459 0           $query .= " WHERE $c1 = ?";
460             }
461 0           $done_where = 1;
462             }
463 0           push @query_args, $arg;
464             }
465             }
466             # $query .= ' ORDER BY entry LIMIT 1';
467 0           $query .= ' LIMIT 1';
468 0 0         if($self->{'logger'}) {
469 0 0         if(defined($query_args[0])) {
470 0           my @call_details = caller(0);
471 0           $self->{'logger'}->debug("fetchrow_hashref $query: ", join(', ', @query_args),
472             ' called from ', $call_details[2], ' of ', $call_details[1]);
473             } else {
474 0           $self->{'logger'}->debug("fetchrow_hashref $query");
475             }
476             }
477 0           my $key;
478 0 0         if(defined($query_args[0])) {
479 0           $key = "fetchrow $query " . join(', ', @query_args);
480             } else {
481 0           $key = "fetchrow $query";
482             }
483 0           my $c;
484 0 0         if($c = $self->{cache}) {
485 0 0         if(my $rc = $c->get($key)) {
486 0           return $rc;
487             }
488             }
489 0 0         my $sth = $self->{$table}->prepare($query) or die $self->{$table}->errstr();
490 0 0         $sth->execute(@query_args) || throw Error::Simple("$query: @query_args");
491 0 0         if($c) {
492 0           my $rc = $sth->fetchrow_hashref();
493 0           $c->set($key, $rc, '1 hour');
494 0           return $rc;
495             }
496 0           return $sth->fetchrow_hashref();
497             }
498              
499             # Execute the given SQL on the data
500             # In an array context, returns an array of hash refs,
501             # in a scalar context returns a hash of the first row
502             sub execute {
503 0     0 0   my $self = shift;
504 0           my %args;
505              
506 0 0         if(ref($_[0]) eq 'HASH') {
    0          
    0          
507 0           %args = %{$_[0]};
  0            
508             } elsif(ref($_[0])) {
509 0           Carp::croak('Usage: execute(query => $query)');
510             } elsif(scalar(@_) % 2 == 0) {
511 0           %args = @_;
512             } else {
513 0           $args{'query'} = shift;
514             }
515              
516 0 0         Carp::croak('Usage: execute(query => $query)') unless(defined($args{'query'}));
517              
518 0   0       my $table = $self->{table} || ref($self);
519 0           $table =~ s/.*:://;
520              
521 0 0         $self->_open() if(!$self->{$table});
522              
523 0           my $query = $args{'query'};
524 0 0         if($self->{'logger'}) {
525 0           $self->{'logger'}->debug("execute $query");
526             }
527 0           my $sth = $self->{$table}->prepare($query);
528 0 0         $sth->execute() || throw Error::Simple($query);
529 0           my @rc;
530 0           while(my $href = $sth->fetchrow_hashref()) {
531 0 0         return $href if(!wantarray);
532 0           push @rc, $href;
533             }
534              
535 0           return @rc;
536             }
537              
538             # Time that the database was last updated
539             sub updated {
540 0     0 0   my $self = shift;
541              
542 0           return $self->{'_updated'};
543             }
544              
545             # Return the contents of an arbitrary column in the database which match the
546             # given criteria
547             # Returns an array of the matches, or just the first entry when called in
548             # scalar context
549              
550             # Set distinct to 1 if you're after a unique list
551             sub AUTOLOAD {
552 0     0     our $AUTOLOAD;
553 0           my $column = $AUTOLOAD;
554              
555 0           $column =~ s/.*:://;
556              
557 0 0         return if($column eq 'DESTROY');
558              
559 0 0         my $self = shift or return;
560              
561 0   0       my $table = $self->{table} || ref($self);
562 0           $table =~ s/.*:://;
563              
564 0 0         $self->_open() if(!$self->{$table});
565              
566 0 0         my %params = (ref($_[0]) eq 'HASH') ? %{$_[0]} : @_;
  0            
567              
568 0           my $query;
569 0           my $done_where = 0;
570 0 0 0       if(wantarray && !delete($params{'distinct'})) {
571 0 0 0       if(($self->{'type'} eq 'CSV') && !$self->{no_entry}) {
572 0           $query = "SELECT $column FROM $table WHERE entry IS NOT NULL AND entry NOT LIKE '#%'";
573 0           $done_where = 1;
574             } else {
575 0           $query = "SELECT $column FROM $table";
576             }
577             } else {
578 0 0 0       if(($self->{'type'} eq 'CSV') && !$self->{no_entry}) {
579 0           $query = "SELECT DISTINCT $column FROM $table WHERE entry IS NOT NULL AND entry NOT LIKE '#%'";
580 0           $done_where = 1;
581             } else {
582 0           $query = "SELECT DISTINCT $column FROM $table";
583             }
584             }
585 0           my @args;
586 0           while(my ($key, $value) = each %params) {
587 0 0         if(defined($value)) {
588 0 0         if($done_where) {
589 0           $query .= " AND $key = ?";
590             } else {
591 0           $query .= " WHERE $key = ?";
592 0           $done_where = 1;
593             }
594 0           push @args, $value;
595             } else {
596 0 0         if($self->{'logger'}) {
597 0           $self->{'logger'}->debug("AUTOLOAD params $key isn't defined");
598             }
599 0 0         if($done_where) {
600 0           $query .= " AND $key IS NULL";
601             } else {
602 0           $query .= " WHERE $key IS NULL";
603 0           $done_where = 1;
604             }
605             }
606             }
607 0           $query .= " ORDER BY $column";
608 0 0         if(!wantarray) {
609 0           $query .= ' LIMIT 1';
610             }
611 0 0         if($self->{'logger'}) {
612 0 0 0       if(scalar(@args) && $args[0]) {
613 0           $self->{'logger'}->debug("AUTOLOAD $query: ", join(', ', @args));
614             } else {
615 0           $self->{'logger'}->debug("AUTOLOAD $query");
616             }
617             }
618 0   0       my $sth = $self->{$table}->prepare($query) || throw Error::Simple($query);
619 0 0         $sth->execute(@args) || throw Error::Simple($query);
620              
621 0 0         if(wantarray) {
622 0           return map { $_->[0] } @{$sth->fetchall_arrayref()};
  0            
  0            
623             }
624 0           return $sth->fetchrow_array(); # Return the first match only
625             }
626              
627             sub DESTROY {
628 0 0 0 0     if(defined($^V) && ($^V ge 'v5.14.0')) {
629 0 0         return if ${^GLOBAL_PHASE} eq 'DESTRUCT'; # >= 5.14.0 only
630             }
631 0           my $self = shift;
632              
633 0 0         if($self->{'temp'}) {
634 0           unlink delete $self->{'temp'};
635             }
636 0 0         if(my $table = delete $self->{'table'}) {
637 0           $table->finish();
638             }
639             }
640              
641             1;