| File: | blib/lib/Database/Abstraction.pm |
| Coverage: | 75.3% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package Database::Abstraction; | |||||
| 2 | ||||||
| 3 | # Author Nigel Horne: njh@nigelhorne.com | |||||
| 4 | # Copyright (C) 2015-2026, Nigel Horne | |||||
| 5 | ||||||
| 6 | # Usage is subject to licence terms. | |||||
| 7 | ||||||
| 8 | # TODO: Switch "entry" to off by default, and enable by passing 'entry' | |||||
| 9 | # though that wouldn't be so nice for AUTOLOAD | |||||
| 10 | # TODO: support a directory hierarchy of databases | |||||
| 11 | # TODO: consider returning an object or array of objects, rather than hashes | |||||
| 12 | # TODO: Add redis database - could be of use for Geo::Coder::Free | |||||
| 13 | # use select() to select a database - use the table arg | |||||
| 14 | # new(database => 'redis://servername'); | |||||
| 15 | # TODO: Add a "key" property, defaulting to "entry", which would be the name of the key | |||||
| 16 | # TODO: The maximum number to return should be tuneable (as a LIMIT) | |||||
| 17 | # TODO: Add full CRUD support | |||||
| 18 | # TODO: It would be better for the default sep_char to be ',' rather than '!' | |||||
| 19 | # TODO: Other databases e.g., Redis, noSQL, remote databases such as MySQL, PostgreSQL | |||||
| 20 | # TODO: The no_entry/entry terminology is confusing. Replace with no_id/id_column | |||||
| 21 | # TODO: Log queries and the time that they took to execute per database | |||||
| 22 | ||||||
| 23 | 35 35 35 | 3381135 29 718 | use warnings; | |||
| 24 | 35 35 35 | 56 24 329 | use strict; | |||
| 25 | 35 35 35 | 5228 177132 69 | use autodie qw(:all); | |||
| 26 | ||||||
| 27 | 35 35 35 | 236819 14877 72 | use boolean; | |||
| 28 | 35 35 35 | 1071 26 633 | use Carp; | |||
| 29 | 35 35 35 | 7257 652372 134 | use Class::Abstract; | |||
| 30 | 35 35 35 | 10333 50143 760 | use Data::Reuse; | |||
| 31 | 35 35 35 | 25091 262093 1010 | use DBI; | |||
| 32 | 35 35 35 | 103 25 3423 | use Fcntl; # For O_RDONLY | |||
| 33 | 35 35 35 | 79 27 757 | use Cwd; | |||
| 34 | 35 35 35 | 60 26 356 | use File::Spec; | |||
| 35 | 35 35 35 | 6977 125772 1133 | use File::Temp; | |||
| 36 | 35 35 35 | 81 44 914 | use List::Util qw(all); | |||
| 37 | 35 35 35 | 10298 1246646 703 | use Log::Abstraction 0.33; | |||
| 38 | 35 35 35 | 9651 187381 690 | use Object::Configure 0.16; | |||
| 39 | 35 35 35 | 110 170 590 | use Params::Get 0.17; | |||
| 40 | 35 35 35 | 68 29 546 | use Return::Set qw(set_return); | |||
| 41 | 35 35 35 | 57 29 359 | use Scalar::Util; | |||
| 42 | 35 35 35 | 55 22 97 | use Sub::Private; | |||
| 43 | 35 35 35 | 10116 132359 89 | use Sub::Protected; | |||
| 44 | ||||||
| 45 | # File::Slurp::Remote is loaded lazily in _open() when host => '...' is given. | |||||
| 46 | ||||||
| 47 | our %defaults; | |||||
| 48 | 35 35 35 | 3240 28 75328 | use constant DEFAULT_MAX_SLURP_SIZE => 16 * 1024; # CSV files <= than this size are read into memory | |||
| 49 | ||||||
| 50 | # Compiled once at module load; reused in every identifier-safety check. | |||||
| 51 | # Using \A/\z (true string anchors) rather than ^/$ which match around \n. | |||||
| 52 | # SAFE_IDENTIFIER: bare SQL identifier â letters, digits, underscore. | |||||
| 53 | # SAFE_QUALIFIED: allows a single dot for table.column notation in JOINs. | |||||
| 54 | my $SAFE_IDENTIFIER = qr/\A[a-zA-Z_][a-zA-Z0-9_]*\z/; | |||||
| 55 | my $SAFE_QUALIFIED = qr/\A[a-zA-Z_][a-zA-Z0-9_.]*\z/; | |||||
| 56 | ||||||
| 57 | # Module-level constant: valid JOIN types after uc() normalisation. | |||||
| 58 | # Built once at compile time; reused by every _build_joins call. | |||||
| 59 | my %VALID_JOIN_TYPES = map { $_ => 1 } qw(INNER LEFT RIGHT FULL CROSS); | |||||
| 60 | ||||||
| 61 - 69 | =head1 NAME Database::Abstraction - Read-only Database Abstraction Layer (ORM) =head1 VERSION Version 0.41 =cut | |||||
| 70 | ||||||
| 71 | our $VERSION = '0.41'; | |||||
| 72 | ||||||
| 73 - 373 | =head1 DESCRIPTION
C<Database::Abstraction> is a read-only ORM for Perl that gives a uniform
interface over CSV, PSV, XML, SQLite, DBM::Deep, BerkeleyDB, and Excel (XLSX)
files - local, remote (via SSH), or fetched from a URL - without writing any
SQL.
Key features:
=over 4
=item *
B<No SQL required.> Use plain Perl method calls for simple lookups and
scans; switch storage formats without changing application code.
=item *
B<Rich query criteria.> Pass plain values, SQL wildcards, C<undef> (IS NULL),
comparison operators (C<< > >> C<< < >> C<< >= >> C<< <= >> C<!=>), pattern
operators (C<-like>, C<-not_like>), set operators (C<-in>, C<-not_in>,
C<-between>), and logical groupings (C<-or>, C<-and>).
=item *
B<Automatic joins.> Add a C<join> parameter to any select method to
combine tables with INNER, LEFT, RIGHT, FULL, or CROSS joins.
=item *
B<Chained query builder.> The C<query()> method returns a
L<Database::Abstraction::Query> object for fluent, composable queries:
C<< $db->query->where(...)->order_by(...)->limit(...)->all() >>.
=item *
B<Schema introspection.> C<columns()> lists column names; C<schema()>
returns full type/nullability metadata, using native driver introspection
(C<PRAGMA table_info> for SQLite, C<column_info> for others).
=item *
B<DSN portability.> Pass a C<dsn> (plus optional C<username>/C<password>)
to connect to any DBI-supported database (SQLite, PostgreSQL, MySQL, ...)
instead of pointing at a local file.
=item *
B<Performance.> Small files are slurped into a RAM hash for sub-millisecond
lookups. All DBI statement handles are cached with C<prepare_cached()>.
A CHI-compatible cache layer is also supported.
=back
=head1 SYNOPSIS
# 1. Create a thin subclass for your table (e.g. Database/Foo.pm)
package Database::Foo;
use parent 'Database::Abstraction';
# 2. Open the database - file is auto-detected from the class name
# (looks for foo.sql / foo.psv / foo.csv / foo.xlsx / foo.xml / foo.db)
my $db = Database::Foo->new(directory => '/path/to/data');
# 3. Simple lookups -----------------------------------------------
# Fetch one row
my $row = $db->fetchrow_hashref(entry => 'key1');
# Fetch all rows matching a criterion
my $rows = $db->selectall_arrayref(status => 'active');
# Column shortcut via AUTOLOAD
my $name = $db->name(entry => 'key1');
# 4. Rich criteria ------------------------------------------------
# Comparison operators
my $high = $db->selectall_arrayref(score => { '>' => 90 });
# Set membership
my $selected = $db->selectall_arrayref(
name => { -in => ['Alice', 'Bob'] }
);
# Range
my $mid = $db->selectall_arrayref(
score => { -between => [60, 80] }
);
# OR grouping
my $either = $db->selectall_arrayref(
-or => [
{ status => 'active' },
{ score => { '>' => 95 } },
]
);
# 5. Joins --------------------------------------------------------
my $joined = $db->selectall_arrayref(
join => { table => 'dept', on => 'foo.dept_id = dept.id', type => 'LEFT' }
);
# 6. Chained query builder ----------------------------------------
my $results = $db->query
->where(status => 'active')
->where(score => { '>=' => 80 })
->order_by('score DESC')
->limit(10)
->all();
my $first = $db->query->where(name => 'Alice')->first();
my $count = $db->query->where(status => 'active')->count();
# 7. Connect via DSN (PostgreSQL, MySQL, SQLite, ...) ---------------
my $db2 = Database::Foo->new(
dsn => 'dbi:Pg:dbname=mydb;host=db.example.com',
username => 'myuser',
password => 's3cret',
);
# 8. Schema introspection -----------------------------------------
my $cols = $db->columns(); # ['entry', 'name', 'score', ...]
my $schema = $db->schema(); # { name => { type=>'TEXT', nullable=>1, ... }, ... }
=head1 QUICK START EXAMPLE
If F</var/dat/foo.csv> contains:
"customer_id","name"
"plugh","John"
"xyzzy","Jane"
Create a driver in F<.../Database/foo.pm>:
package Database::foo;
use parent 'Database::Abstraction';
# Regular CSV: no entry column, comma-separated
sub new {
my ($class, %args) = @_;
return $class->SUPER::new(no_entry => 1, sep_char => ',', %args);
}
Then query it:
my $foo = Database::foo->new(directory => '/var/dat');
# Prints "John"
print 'Customer: ', $foo->name(customer_id => 'plugh'), "\n";
# Returns { customer_id => 'xyzzy', name => 'Jane' }
my $row = $foo->fetchrow_hashref(customer_id => 'xyzzy');
=head1 FILE FORMATS
The module probes the C<directory> for files in this priority order:
=over 4
=item 1. C<SQLite>
File ending C<.sql>
=item 2. C<Deep>
DBM::Deep file ending C<.dbm> or C<.deep>. The entire file is slurped
into a plain Perl hash on open; all in-memory fast-paths apply.
Requires L<DBM::Deep> (loaded lazily).
=item 3. C<PSV>
Pipe-separated file, ending C<.psv>
=item 4. C<CSV>
Comma (or custom) separated file, ending C<.csv> or C<.db>; can be
gzipped. B<Note:> the default separator is C<!> not C<,> for historical
reasons - pass C<< sep_char => ',' >> for standard CSVs.
=item 5. C<Excel>
Excel workbook ending C<.xlsx>. Each worksheet is a separate SQL table;
the active worksheet is determined by the class-derived table name (or the
C<table> constructor parameter - see L</SUBROUTINES/METHODS>). Requires
L<DBD::Excel> (loaded lazily); L<Spreadsheet::ParseXLSX> is used
automatically for modern C<.xlsx> files when installed. No slurp path:
C<max_slurp_size> has no effect on the Excel backend.
=item 6. C<XML>
File ending C<.xml>
=item 7. C<BerkeleyDB>
Binary key-value file ending C<.db>
=item 8. C<HTML>
Remote HTML page fetched via a URL. Pass C<url> instead of C<directory>; the
module fetches the page with L<LWP::UserAgent>, parses all C<< <table> >>
elements with L<HTML::TableExtract>, and slurps the first (or
C<html_table_index>-selected) table into memory. The first row of the table
is treated as column headers. Both modules are loaded lazily and are not
required for other backends.
=back
Pass C<dsn> to bypass file detection entirely and connect via any DBI driver.
Pass C<url> to fetch and slurp a remote HTML table without a local directory.
=head1 QUERY CRITERIA
All select methods (C<selectall_arrayref>, C<selectall_array>,
C<fetchrow_hashref>, C<count>) accept the same criteria syntax.
=head2 Plain value
status => 'active' # status = 'active'
name => undef # name IS NULL
Values containing C<%> or C<_> are matched with C<LIKE>:
name => 'A%' # name LIKE 'A%'
=head2 Comparison operator hashref
score => { '>' => 90 } # score > 90
score => { '<' => 50 } # score < 50
score => { '>=' => 80 } # score >= 80
score => { '<=' => 100 } # score <= 100
score => { '!=' => 0 } # score != 0
Multiple operators on one column are ANDed:
score => { '>' => 60, '<' => 90 } # 60 < score < 90
=head2 Pattern matching
name => { -like => 'A%' } # name LIKE 'A%'
name => { -not_like => 'Z%' } # name NOT LIKE 'Z%'
=head2 Set membership
name => { -in => ['Alice', 'Bob'] } # name IN (...)
name => { -not_in => ['Alice', 'Bob'] } # name NOT IN (...)
=head2 Range
score => { -between => [60, 90] } # score BETWEEN 60 AND 90
=head2 Logical groupings
C<-or> and C<-and> take an arrayref of condition hashrefs:
-or => [
{ status => 'active' },
{ score => { '>' => 95 } },
]
-and => [
{ status => 'active' },
{ score => { '>=' => 80 } },
]
=head2 Joins
Any select method accepts a C<join> key with a hashref (or arrayref of
hashrefs) describing the join:
join => {
table => 'dept',
on => 'employees.dept_id = dept.id',
type => 'LEFT', # INNER (default) | LEFT | RIGHT | FULL | CROSS
}
# Multiple joins
join => [
{ table => 'dept', on => 'e.dept_id = dept.id' },
{ table => 'country', on => 'e.country_id = country.id' },
]
=head1 SUBROUTINES/METHODS
=head2 init
Set class-level defaults shared by all instances.
Database::Abstraction::init(directory => '../data');
Accepts the same parameters as L</new>. Returns a reference to the
current defaults hash, so you can read them back:
my $defaults = Database::Abstraction::init();
print $defaults->{'directory'}, "\n";
=cut | |||||
| 374 | ||||||
| 375 | # Subroutine to initialize with args | |||||
| 376 | sub init | |||||
| 377 | { | |||||
| 378 | 141 | 938007 | if(my $params = Params::Get::get_params(undef, @_)) { | |||
| 379 | 135 | 1843 | if(($params->{'expires_in'} && !$params->{'cache_duration'})) { | |||
| 380 | # Compatibility with CHI | |||||
| 381 | 4 | 7 | $params->{'cache_duration'} = $params->{'expires_in'}; | |||
| 382 | } | |||||
| 383 | ||||||
| 384 | 135 135 | 144 288 | %defaults = (%defaults, %{$params}); | |||
| 385 | 135 | 498 | $defaults{'cache_duration'} ||= '1 hour'; | |||
| 386 | } | |||||
| 387 | ||||||
| 388 | 141 | 13354 | return \%defaults | |||
| 389 | } | |||||
| 390 | ||||||
| 391 - 401 | =head2 import
The module can be initialised by the C<use> directive.
use Database::Abstraction 'directory' => '/etc/data';
or
use Database::Abstraction { 'directory' => '/etc/data' };
=cut | |||||
| 402 | ||||||
| 403 | sub import | |||||
| 404 | { | |||||
| 405 | 118 | 653033 | my $pkg = shift; | |||
| 406 | ||||||
| 407 | 118 | 476 | if((scalar(@_) == 0) && (ref($pkg) eq 'HASH')) { | |||
| 408 | 0 | 0 | init(Object::Configure::configure(__PACKAGE__, $pkg)); | |||
| 409 | } elsif((scalar(@_) % 2) == 0) { | |||||
| 410 | 115 | 122 | my %h = @_; | |||
| 411 | 115 | 255 | init(Object::Configure::configure($pkg, \%h)); | |||
| 412 | } elsif((scalar(@_) == 1) && (ref($_[0]) eq 'HASH')) { | |||||
| 413 | 3 | 7 | init(Object::Configure::configure($pkg, $_[0])); | |||
| 414 | } elsif(scalar(@_) > 0) { # >= 3 would also work here | |||||
| 415 | 0 | 0 | init(\@_); | |||
| 416 | } | |||||
| 417 | } | |||||
| 418 | ||||||
| 419 - 582 | =head2 new Create an object pointing to a read-only database. Accepts arguments as a hash, a hashref, or - as a shortcut - a single bare string which is taken to be C<directory>. =head3 Connection parameters =over 4 =item * C<directory> Directory containing the data files. The module probes this directory for files named after the subclass (see L</FILE FORMATS>). Required unless C<dsn> is given. =item * C<dsn> A DBI data-source string (e.g. C<dbi:SQLite:dbname=/path/to/db> or C<dbi:Pg:dbname=mydb;host=db.example.com>). When present, file detection is skipped entirely and the DSN is used directly. The SQL dialect is inferred from the DSN prefix (C<sqlite>, C<postgres>, C<mysql>). =item * C<username> Database username. Used only with C<dsn>; ignored for file-based backends. =item * C<password> Database password. Used only with C<dsn>; ignored for file-based backends. =item * C<dbname> Override the filename stem searched in C<directory> (default: the table name derived from the class name). =item * C<table> Override the table (or worksheet) name used in SQL queries for this object. Default is the class-name-derived table name (e.g. C<Database::Foo> => C<foo>). Particularly useful for Excel workbooks where a single F<.xlsx> file contains multiple worksheets: pass C<< table => 'Summary' >> to query the C<Summary> worksheet without creating a dedicated subclass. Also works with SQLite/DSN connections to select a table other than the class-derived default. The filename stem (C<dbname>) continues to fall back to the class name, so the correct file is opened regardless of this override. The value is validated against C<$SAFE_QUALIFIED> at construction time. =item * C<filename> Override the full filename (relative to C<directory>). Takes precedence over C<dbname>. =item * C<host> Remote hostname (or C<user@host>) from which to fetch the data file(s) via SSH/SCP. When present, each candidate filename is fetched with L<File::Slurp::Remote> into a local temporary directory; the existing extension-based file-type detection then runs against that directory. C<directory> is treated as the remote path (no local canonicalization is applied). Using C<filename> together with C<host> avoids probing multiple extensions and is therefore more efficient. L<File::Slurp::Remote> must be installed; it is loaded lazily (only when C<host> is given). =item * C<url> A URL (C<http://> or C<https://>) pointing to an HTML page that contains one or more C<< <table> >> elements. When present, C<directory> is not required. The first row of the selected table is used as column headers. Requires L<LWP::UserAgent> and L<HTML::TableExtract> (both loaded lazily). =back =head3 Behaviour parameters =over 4 =item * C<no_entry> Set to C<1> when the table has no key column (standard CSVs, for example). Default is C<0> (keyed on C<entry>). =item * C<id> Name of the key column. Default is C<entry>. =item * C<sep_char> Field separator for CSV/PSV files. Default is C<!> - pass C<< sep_char => ',' >> for standard comma-separated files. =item * C<max_slurp_size> Files smaller than this (in bytes) are loaded entirely into memory for fast lookups. Default is 16 KB. Set to C<0> to force SQL mode for all sizes. =item * C<no_fixate> Set to C<1> to return mutable arrays. Default is C<0> (arrays are made read-only via L<Data::Reuse>). =item * C<auto_load> Set to C<0> to disable the AUTOLOAD column shortcut. Default is C<1> (enabled). =item * C<html_table_index> Zero-based index of the HTML C<< <table> >> to extract when the C<url> backend is used. Default is C<0> (the first table on the page). =back =head3 Caching and logging =over 4 =item * C<cache> A L<CHI>-compatible cache object. When set, query results are stored and retrieved from the cache. =item * C<cache_duration> / C<expires_in> TTL for cached results. Default is C<'1 hour'>. C<expires_in> is a synonym for compatibility with L<CHI>. =item * C<logger> An object that understands C<warn()> and C<trace()> (e.g. L<Log::Log4perl>, L<Log::Any>), a code reference, or a filename. =item * C<config_file> Path to a YAML, XML, or INI configuration file whose keys are merged into the constructor arguments. Loaded via L<Object::Configure>. =back =head3 Notes =over 4 =item * If no arguments are set, class-level defaults set via C<init()> or C<use> are used. =item * Slurp mode assumes the key column (C<entry>) is unique. If it is not, searches will be incomplete - disable slurp mode by setting C<< max_slurp_size => 0 >>. =item * Passing an existing object as C<$class> clones it, merging any new arguments. =back =cut | |||||
| 583 | ||||||
| 584 | sub new { | |||||
| 585 | 477 | 2144335 | my $class = shift; | |||
| 586 | 477 | 436 | my %args; | |||
| 587 | ||||||
| 588 | 477 | 891 | Class::Abstract::check_abstract($class); # enforces abstract contract | |||
| 589 | ||||||
| 590 | # Handle hash or hashref arguments | |||||
| 591 | 477 | 3720 | if((scalar(@_) == 1) && !ref($_[0])) { | |||
| 592 | 98 | 355 | $args{'directory'} = $_[0]; | |||
| 593 | } elsif(my $params = Params::Get::get_params(undef, @_)) { | |||||
| 594 | 369 369 | 5014 636 | %args = %{$params}; | |||
| 595 | } | |||||
| 596 | ||||||
| 597 | 477 | 1367 | if(!defined($class)) { | |||
| 598 | 0 | 0 | if((scalar keys %args) > 0) { | |||
| 599 | # Using Database::Abstraction->new(), not Database::Abstraction::new() | |||||
| 600 | 0 | 0 | carp(__PACKAGE__, ' use ->new() not ::new() to instantiate'); | |||
| 601 | 0 | 0 | return; | |||
| 602 | } | |||||
| 603 | # FIXME: this only works when no arguments are given | |||||
| 604 | 0 | 0 | $class = __PACKAGE__; | |||
| 605 | } elsif($class eq __PACKAGE__) { | |||||
| 606 | 6 | 60 | croak("$class: abstract class"); | |||
| 607 | } elsif(Scalar::Util::blessed($class)) { | |||||
| 608 | # If $class is an object, clone it with new arguments. | |||||
| 609 | # Validate 'id' and 'table' before merging â the validation block below is | |||||
| 610 | # skipped by this early return, so hostile clone args would otherwise bypass | |||||
| 611 | # all guards and be interpolated directly into SQL. | |||||
| 612 | 10 | 18 | if(defined $args{'id'}) { | |||
| 613 | croak(ref($class), ": unsafe id column name '$args{id}'") | |||||
| 614 | 3 | 45 | unless $args{'id'} =~ $SAFE_IDENTIFIER; | |||
| 615 | } | |||||
| 616 | 7 | 12 | if(defined $args{'table'}) { | |||
| 617 | croak(ref($class), ": unsafe table name '$args{table}'") | |||||
| 618 | 1 | 15 | unless $args{'table'} =~ $SAFE_QUALIFIED; | |||
| 619 | } | |||||
| 620 | 6 6 | 18 36 | return bless { %{$class}, %args }, ref($class); | |||
| 621 | } | |||||
| 622 | ||||||
| 623 | # Load the configuration from a config file, if provided | |||||
| 624 | 461 461 | 331 728 | %args = %{Object::Configure::configure($class, \%args)}; | |||
| 625 | ||||||
| 626 | # Normalise logger: wrap code-refs, filenames, and strings in Log::Abstraction | |||||
| 627 | # so that the rest of the code can always call ->$level(...) uniformly. | |||||
| 628 | 461 | 849848 | if(defined $args{'logger'} && !Scalar::Util::blessed($args{'logger'})) { | |||
| 629 | 0 | 0 | $args{'logger'} = Log::Abstraction->new($args{'logger'}); | |||
| 630 | } | |||||
| 631 | ||||||
| 632 | 461 | 1625 | unless($args{'dsn'} || $defaults{'dsn'} || $args{'url'} || $defaults{'url'}) { | |||
| 633 | 407 | 691 | croak("$class: where are the files?") unless($args{'directory'} || $defaults{'directory'}); | |||
| 634 | ||||||
| 635 | # Skip the local -d check only for genuinely remote hosts. | |||||
| 636 | # localhost / 127.0.0.1 / current hostname are treated as local. | |||||
| 637 | 401 | 625 | my $given_host = $args{'host'} // $defaults{'host'}; | |||
| 638 | 401 | 518 | unless($given_host && !$class->_is_local_host($given_host)) { | |||
| 639 | 395 | 2381 | croak("$class: ", $args{'directory'} || $defaults{'directory'}, ' is not a directory') unless(-d ($args{'directory'} || $defaults{'directory'})); | |||
| 640 | } | |||||
| 641 | } | |||||
| 642 | ||||||
| 643 | # Validate the primary-key column name to prevent SQL injection via ORDER BY / WHERE | |||||
| 644 | 444 | 480 | for my $src (\%defaults, \%args) { | |||
| 645 | 888 | 854 | if(defined $src->{'id'}) { | |||
| 646 | croak("$class: unsafe id column name '$src->{id}'") | |||||
| 647 | 51 | 414 | unless $src->{'id'} =~ $SAFE_IDENTIFIER; | |||
| 648 | } | |||||
| 649 | 870 | 764 | if(defined $src->{'host'}) { | |||
| 650 | croak("$class: unsafe host '$src->{host}'") | |||||
| 651 | 18 | 104 | unless $src->{'host'} =~ /\A | |||
| 652 | (?: # optional "user\@" prefix | |||||
| 653 | [a-zA-Z0-9] # username: first char must be alnum | |||||
| 654 | [a-zA-Z0-9._-]* # username: rest may include dots and hyphens | |||||
| 655 | \@ # literal at-sign; \@ prevents array interpolation | |||||
| 656 | )? | |||||
| 657 | [a-zA-Z0-9:] # first char of host or IP; colon allows IPv6 | |||||
| 658 | [a-zA-Z0-9._:-]* # rest: hostname, dotted IPv4, or IPv6 hex groups | |||||
| 659 | \z/x; | |||||
| 660 | } | |||||
| 661 | 865 | 755 | if(defined $src->{'url'}) { | |||
| 662 | croak("$class: unsafe url '$src->{url}'") | |||||
| 663 | 22 | 131 | unless $src->{'url'} =~ /\Ahttps?:\/\//i; | |||
| 664 | } | |||||
| 665 | 858 | 869 | if(defined $src->{'table'}) { | |||
| 666 | croak("$class: unsafe table name '$src->{table}'") | |||||
| 667 | 15 | 172 | unless $src->{'table'} =~ $SAFE_QUALIFIED; | |||
| 668 | } | |||||
| 669 | } | |||||
| 670 | ||||||
| 671 | # Defaults are set first so that %args keys override them | |||||
| 672 | 404 | 2004 | return bless { | |||
| 673 | no_entry => 0, | |||||
| 674 | no_fixate => 0, | |||||
| 675 | id => 'entry', | |||||
| 676 | cache_duration => '1 hour', | |||||
| 677 | max_slurp_size => DEFAULT_MAX_SLURP_SIZE, | |||||
| 678 | %defaults, | |||||
| 679 | %args, | |||||
| 680 | }, $class; | |||||
| 681 | } | |||||
| 682 | ||||||
| 683 - 687 | =head2 set_logger Sets the class, code reference, or file that will be used for logging. =cut | |||||
| 688 | ||||||
| 689 | sub set_logger | |||||
| 690 | { | |||||
| 691 | 16 | 3988 | my $self = shift; | |||
| 692 | 16 | 38 | my $params = Params::Get::get_params('logger', @_); | |||
| 693 | ||||||
| 694 | 13 | 166 | if(my $logger = $params->{'logger'}) { | |||
| 695 | 12 | 23 | if(Scalar::Util::blessed($logger)) { | |||
| 696 | 4 | 11 | $self->{'logger'} = $logger; | |||
| 697 | } else { | |||||
| 698 | 8 | 15 | $self->{'logger'} = Log::Abstraction->new($logger); | |||
| 699 | } | |||||
| 700 | 12 | 152 | return $self; | |||
| 701 | } | |||||
| 702 | 1 | 17 | Carp::croak('Usage: set_logger(logger => $logger)') | |||
| 703 | } | |||||
| 704 | ||||||
| 705 | # Open the database connection based on the specified type (e.g., SQLite, CSV). | |||||
| 706 | # Read the data into memory or establish a connection to the database file. | |||||
| 707 | # column_names allows the column names to be overridden on CSV files | |||||
| 708 | ||||||
| 709 | sub _open :Protected | |||||
| 710 | { | |||||
| 711 | # Enforce that _open is only reachable from within this class hierarchy; | |||||
| 712 | # caller() returns the calling package name as a plain string. | |||||
| 713 | 11 11 11 | 33 27 121 | do { my $c = (caller)[0]; Carp::croak('Illegal Operation: _open may only be called within ', __PACKAGE__) unless $c && $c->isa(__PACKAGE__) }; | |||
| 714 | ||||||
| 715 | 11 | 8 | my $self = shift; | |||
| 716 | 11 | 24 | my $params = Params::Get::get_params(undef, @_); | |||
| 717 | ||||||
| 718 | 11 | 122 | $params->{'sep_char'} ||= $self->{'sep_char'} ? $self->{'sep_char'} : '!'; | |||
| 719 | 11 | 26 | my $max_slurp_size = $params->{'max_slurp_size'} || $self->{'max_slurp_size'}; | |||
| 720 | ||||||
| 721 | 11 | 40 | my $table = $self->{'table'} || ref($self); | |||
| 722 | 11 | 18 | $table =~ s/\A.*:://; | |||
| 723 | ||||||
| 724 | 11 | 35 | $self->_trace(ref($self), ": _open $table"); | |||
| 725 | ||||||
| 726 | 11 | 1710 | return if($self->{$table}); | |||
| 727 | ||||||
| 728 | # Read in the database | |||||
| 729 | 11 | 13 | my $dbh; | |||
| 730 | ||||||
| 731 | # DSN-based connection bypasses file detection entirely | |||||
| 732 | 11 | 31 | if(my $dsn = $self->{'dsn'} || $defaults{'dsn'}) { | |||
| 733 | 0 | 0 | my $dialect = 'generic'; | |||
| 734 | 0 0 | 0 0 | if ($dsn =~ /^dbi:SQLite:/i) { $dialect = 'sqlite' } | |||
| 735 | 0 | 0 | elsif ($dsn =~ /^dbi:Pg:/i) { $dialect = 'postgres' } | |||
| 736 | 0 | 0 | elsif ($dsn =~ /^dbi:mysql:/i) { $dialect = 'mysql' } | |||
| 737 | 0 | 0 | $self->{'_dialect'} = $dialect; | |||
| 738 | ||||||
| 739 | $dbh = DBI->connect( | |||||
| 740 | $dsn, | |||||
| 741 | $self->{'username'}, | |||||
| 742 | 0 | 0 | $self->{'password'}, | |||
| 743 | { RaiseError => 1, AutoCommit => 1 }, | |||||
| 744 | ) or Carp::croak(ref($self), ": cannot connect: $DBI::errstr"); | |||||
| 745 | ||||||
| 746 | 0 | 0 | if($dialect eq 'sqlite') { | |||
| 747 | 0 | 0 | $dbh->do('PRAGMA synchronous = OFF'); | |||
| 748 | 0 | 0 | $dbh->do('PRAGMA cache_size = -4096'); | |||
| 749 | 0 | 0 | $dbh->do('PRAGMA journal_mode = OFF'); | |||
| 750 | 0 | 0 | $dbh->do('PRAGMA temp_store = MEMORY'); | |||
| 751 | 0 | 0 | $dbh->do('PRAGMA mmap_size = 1048576'); | |||
| 752 | 0 | 0 | $dbh->sqlite_busy_timeout(100000); | |||
| 753 | } | |||||
| 754 | ||||||
| 755 | 0 | 0 | $self->{'type'} = 'DBI'; | |||
| 756 | 0 | 0 | $self->{$table} = $dbh; | |||
| 757 | 0 | 0 | $self->{'_updated'} = time(); | |||
| 758 | 0 | 0 | return $self; | |||
| 759 | } | |||||
| 760 | ||||||
| 761 | # URL-based HTML table backend â lazy-loads LWP::UserAgent and HTML::TableExtract. | |||||
| 762 | # Both modules are optional; they are not required for file-based backends. | |||||
| 763 | 11 | 27 | if(my $url = $self->{'url'} || $defaults{'url'}) { | |||
| 764 | 0 | 0 | require LWP::UserAgent::Cached; | |||
| 765 | 0 | 0 | require HTML::TableExtract; | |||
| 766 | ||||||
| 767 | 0 | 0 | my $ua = $self->{ua} // LWP::UserAgent::Cached->new(timeout => 30, agent => __PACKAGE__ . '/' . $VERSION); | |||
| 768 | 0 | 0 | $ua->env_proxy(1); | |||
| 769 | 0 | 0 | my $response = $ua->get($url); | |||
| 770 | 0 | 0 | Carp::croak(ref($self), ": cannot fetch '$url': ", $response->status_line) | |||
| 771 | unless $response->is_success; | |||||
| 772 | ||||||
| 773 | 0 | 0 | my $te = HTML::TableExtract->new(); | |||
| 774 | 0 | 0 | $te->parse($response->decoded_content); | |||
| 775 | ||||||
| 776 | 0 | 0 | my $tidx = $self->{'html_table_index'} // $defaults{'html_table_index'} // 0; | |||
| 777 | 0 | 0 | my @tables = $te->tables; | |||
| 778 | 0 | 0 | Carp::croak(ref($self), ": no HTML tables found at '$url'") | |||
| 779 | unless @tables; | |||||
| 780 | 0 | 0 | Carp::croak(ref($self), ": html_table_index $tidx out of range (", scalar @tables, " tables) at '$url'") | |||
| 781 | if $tidx >= @tables; | |||||
| 782 | ||||||
| 783 | 0 | 0 | my @rows = $tables[$tidx]->rows; | |||
| 784 | 0 | 0 | Carp::croak(ref($self), ": empty HTML table at '$url'") | |||
| 785 | unless @rows; | |||||
| 786 | ||||||
| 787 | 0 0 0 | 0 0 0 | my @headers = map { defined($_) ? "$_" : '' } @{$rows[0]}; | |||
| 788 | 0 | 0 | my $id = $self->{'id'}; | |||
| 789 | ||||||
| 790 | 0 | 0 | if($self->{'no_entry'}) { | |||
| 791 | 0 | 0 | my @data; | |||
| 792 | 0 | 0 | for my $i (1 .. $#rows) { | |||
| 793 | 0 | 0 | my %row; | |||
| 794 | 0 0 0 | 0 0 0 | @row{@headers} = map { defined($_) ? "$_" : undef } @{$rows[$i]}; | |||
| 795 | 0 | 0 | push @data, \%row; | |||
| 796 | } | |||||
| 797 | 0 | 0 | $self->{'data'} = \@data; | |||
| 798 | } else { | |||||
| 799 | 0 | 0 | my %data; | |||
| 800 | 0 | 0 | for my $i (1 .. $#rows) { | |||
| 801 | 0 | 0 | my %row; | |||
| 802 | 0 0 0 | 0 0 0 | @row{@headers} = map { defined($_) ? "$_" : undef } @{$rows[$i]}; | |||
| 803 | 0 | 0 | my $key = $row{$id}; | |||
| 804 | 0 | 0 | next unless defined $key; | |||
| 805 | 0 | 0 | $data{$key} = \%row; | |||
| 806 | } | |||||
| 807 | 0 | 0 | $self->{'data'} = \%data; | |||
| 808 | } | |||||
| 809 | ||||||
| 810 | 0 | 0 | $self->{'type'} = 'HTML'; | |||
| 811 | 0 | 0 | $self->{'_updated'} = time(); | |||
| 812 | 0 | 0 | $self->_fixate($self->{'data'}) if $self->{'data'} && ref($self->{'data'}) eq 'HASH'; | |||
| 813 | 0 | 0 | $self->{$table} = undef; # No DBI handle; all queries use the in-memory data path | |||
| 814 | 0 | 0 | return $self; | |||
| 815 | } | |||||
| 816 | ||||||
| 817 | # Derive the filename stem from the class name, NOT from any $table override. | |||||
| 818 | # This allows table => 'Sheet2' to query a different worksheet within the same | |||||
| 819 | # file (e.g. test1.xlsx with a 'sheet2' worksheet) without needing an explicit | |||||
| 820 | # dbname. When dbname is set explicitly it always wins. | |||||
| 821 | 11 | 15 | my $class_stem = ref($self); | |||
| 822 | 11 | 20 | $class_stem =~ s/\A.*:://; | |||
| 823 | 11 | 37 | my $dbname = $self->{'dbname'} || $defaults{'dbname'} || $class_stem; | |||
| 824 | # \A/\z (not ^/$) so a trailing newline cannot sneak past the $ anchor. | |||||
| 825 | 11 | 36 | Carp::croak(ref($self), ": unsafe dbname '$dbname'") | |||
| 826 | unless $dbname =~ /\A[a-zA-Z0-9_.-]+\z/ && $dbname !~ /\.\./; | |||||
| 827 | ||||||
| 828 | # When a remote host is given, fetch all candidate files into a local temp | |||||
| 829 | # directory via File::Slurp::Remote (SSH/SCP). localhost / 127.0.0.1 / the | |||||
| 830 | # current machine's hostname are treated as local (no SSH, no temp dir). | |||||
| 831 | 11 | 7 | my $dir; | |||
| 832 | 11 | 30 | if(my $host = $self->{'host'} || $defaults{'host'}) { | |||
| 833 | 0 | 0 | if($self->_is_local_host($host)) { | |||
| 834 | 0 | 0 | $self->_debug("host '$host' is local; reading directory directly"); | |||
| 835 | 0 | 0 | $dir = Cwd::abs_path($self->{'directory'} || $defaults{'directory'}); | |||
| 836 | } else { | |||||
| 837 | 0 | 0 | require File::Slurp::Remote; | |||
| 838 | 0 | 0 | my $remote_dir = $self->{'directory'} || $defaults{'directory'}; | |||
| 839 | 0 | 0 | my $tmpdir_obj = File::Temp->newdir(CLEANUP => 1); | |||
| 840 | 0 | 0 | $self->{'_remote_tmpdir'} = $tmpdir_obj; # auto-cleans on DESTROY | |||
| 841 | 0 | 0 | my $tmpdir = $tmpdir_obj->dirname(); | |||
| 842 | 0 | 0 | for my $ext (qw(sql dbm deep db csv.gz db.gz psv xlsx csv xml)) { | |||
| 843 | 0 | 0 | my $remote_file = "$remote_dir/$dbname.$ext"; | |||
| 844 | 0 0 | 0 0 | my $content = eval { scalar File::Slurp::Remote::read_remote_file($host, $remote_file) }; | |||
| 845 | 0 | 0 | next unless defined($content) && length($content); | |||
| 846 | 0 | 0 | my $local = File::Spec->catfile($tmpdir, "$dbname.$ext"); | |||
| 847 | 0 | 0 | open(my $fh, '>', $local); | |||
| 848 | 0 | 0 | binmode $fh; | |||
| 849 | 0 | 0 | print $fh $content; | |||
| 850 | 0 | 0 | close $fh; | |||
| 851 | 0 | 0 | $self->_debug("fetched remote $host:$remote_file"); | |||
| 852 | } | |||||
| 853 | 0 | 0 | $dir = $tmpdir; | |||
| 854 | } | |||||
| 855 | } else { | |||||
| 856 | 11 | 197 | $dir = Cwd::abs_path($self->{'directory'} || $defaults{'directory'}); | |||
| 857 | } | |||||
| 858 | 11 | 54 | my $slurp_file = File::Spec->catfile($dir, "$dbname.sql"); | |||
| 859 | ||||||
| 860 | 11 | 32 | $self->_debug("_open: try to open $slurp_file"); | |||
| 861 | ||||||
| 862 | # Probe for DBM::Deep files (.dbm or .deep) before the CSV/BerkeleyDB fallback. | |||||
| 863 | # Loaded lazily so the DBM::Deep module is not required for other backends. | |||||
| 864 | 11 | 564 | my $deep_file; | |||
| 865 | 11 | 10 | for my $ext (qw(dbm deep)) { | |||
| 866 | 22 | 61 | my $candidate = File::Spec->catfile($dir, "$dbname.$ext"); | |||
| 867 | 22 0 0 | 127 0 0 | if(-r $candidate) { $deep_file = $candidate; last } | |||
| 868 | } | |||||
| 869 | # Also detect DBM::Deep files by magic bytes (covers .db files and arbitrary extensions). | |||||
| 870 | 11 | 13 | if(!$deep_file) { | |||
| 871 | 11 | 50 | my $db_candidate = File::Spec->catfile($dir, "$dbname.db"); | |||
| 872 | 11 | 56 | $deep_file = $db_candidate if -r $db_candidate && $self->_is_deep_db($db_candidate); | |||
| 873 | } | |||||
| 874 | ||||||
| 875 | # Look at various places to find the file and derive the file type from the file's name | |||||
| 876 | 11 | 50 | if(-r $slurp_file) { | |||
| 877 | # SQLite file | |||||
| 878 | 0 | 0 | require DBD::SQLite::Constants; | |||
| 879 | 0 | 0 | $dbh = DBI->connect("dbi:SQLite:dbname=$slurp_file", undef, undef, { | |||
| 880 | sqlite_open_flags => DBD::SQLite::Constants::SQLITE_OPEN_READONLY(), | |||||
| 881 | }); | |||||
| 882 | } | |||||
| 883 | 11 | 69 | if($dbh) { | |||
| 884 | 0 | 0 | $dbh->do('PRAGMA synchronous = OFF'); | |||
| 885 | 0 | 0 | $dbh->do('PRAGMA cache_size = -4096'); # Use 4MB cache - negative = KB) | |||
| 886 | 0 | 0 | $dbh->do('PRAGMA journal_mode = OFF'); # Read-only, no journal needed | |||
| 887 | 0 | 0 | $dbh->do('PRAGMA temp_store = MEMORY'); # Store temp data in RAM | |||
| 888 | 0 | 0 | $dbh->do('PRAGMA mmap_size = 1048576'); # Use 1MB memory-mapped I/O | |||
| 889 | 0 | 0 | $dbh->sqlite_busy_timeout(100000); # 10s | |||
| 890 | 0 | 0 | $self->_debug("read in $table from SQLite $slurp_file"); | |||
| 891 | 0 | 0 | $self->{'type'} = 'DBI'; | |||
| 892 | } elsif($deep_file) { | |||||
| 893 | # DBM::Deep file (.dbm or .deep) â slurp the entire tied hash into a plain | |||||
| 894 | # Perl hash so all existing in-memory fast-paths work without modification. | |||||
| 895 | 0 | 0 | require DBM::Deep; | |||
| 896 | 0 | 0 | my $deep = DBM::Deep->new({ file => $deep_file, read_only => 1 }); | |||
| 897 | 0 | 0 | my $id = $self->{'id'}; | |||
| 898 | 0 | 0 | if($self->{'no_entry'}) { | |||
| 899 | # Not keyed â produce an ordered arrayref of row hashrefs, same as CSV no_entry. | |||||
| 900 | 0 | 0 | my @data; | |||
| 901 | 0 0 | 0 0 | for my $k (sort keys %{$deep}) { | |||
| 902 | 0 | 0 | my $row = $deep->{$k}; | |||
| 903 | # Use reftype (not ref) so blessed DBM::Deep::Hash objects are recognised. | |||||
| 904 | # Inject the outer key as the id column so criteria on that column work. | |||||
| 905 | push @data, (Scalar::Util::reftype($row) // '') eq 'HASH' | |||||
| 906 | 0 0 | 0 0 | ? { $id => $k, %{$row} } | |||
| 907 | : { $id => $k, value => $row }; | |||||
| 908 | } | |||||
| 909 | 0 | 0 | $self->{'data'} = @data ? \@data : undef; | |||
| 910 | } else { | |||||
| 911 | # Keyed on the primary-key column (default: 'entry') for O(1) lookups. | |||||
| 912 | # Each row hash must contain the id column (like CSV rows), so that | |||||
| 913 | # selectall_arrayref and AUTOLOAD can access it by name. | |||||
| 914 | 0 | 0 | my %data; | |||
| 915 | 0 0 | 0 0 | for my $k (keys %{$deep}) { | |||
| 916 | 0 | 0 | my $row = $deep->{$k}; | |||
| 917 | $data{$k} = (Scalar::Util::reftype($row) // '') eq 'HASH' | |||||
| 918 | 0 0 | 0 0 | ? { $id => $k, %{$row} } | |||
| 919 | : { $id => $k, value => $row }; | |||||
| 920 | } | |||||
| 921 | 0 | 0 | $self->{'data'} = %data ? \%data : undef; | |||
| 922 | } | |||||
| 923 | 0 | 0 | $slurp_file = $deep_file; | |||
| 924 | 0 | 0 | $self->_debug("read in $table from DBM::Deep $deep_file"); | |||
| 925 | 0 | 0 | $self->{'type'} = 'Deep'; | |||
| 926 | } elsif($self->_is_berkeley_db(File::Spec->catfile($dir, "$dbname.db"))) { | |||||
| 927 | 0 | 0 | $self->_debug("$table is a BerkeleyDB file"); | |||
| 928 | 0 | 0 | $self->{'type'} = 'BerkeleyDB'; | |||
| 929 | } else { | |||||
| 930 | 11 | 16 | my $fin; | |||
| 931 | # File::pfopen splits $path on ':' which breaks Windows drive letters | |||||
| 932 | # (C:\foo becomes ['C', '\foo']). Since we always have a single directory | |||||
| 933 | # we use File::Spec->catfile directly â same behaviour, portable. | |||||
| 934 | my $gz_file; | |||||
| 935 | 11 | 21 | for my $ext (qw(csv.gz db.gz)) { | |||
| 936 | 22 | 66 | my $candidate = File::Spec->catfile($dir, "$dbname.$ext"); | |||
| 937 | 22 | 96 | next unless -r $candidate; | |||
| 938 | 0 | 0 | open($fin, '<', $candidate); | |||
| 939 | 0 | 0 | $gz_file = $candidate; | |||
| 940 | 0 | 0 | last; | |||
| 941 | } | |||||
| 942 | 11 | 21 | if($gz_file) { | |||
| 943 | 0 | 0 | require Gzip::Faster; | |||
| 944 | ||||||
| 945 | 0 | 0 | close($fin); | |||
| 946 | 0 | 0 | $fin = File::Temp->new(SUFFIX => '.csv', UNLINK => 1, CLEANUP => 1); | |||
| 947 | 0 | 0 | print $fin Gzip::Faster::gunzip_file($gz_file); | |||
| 948 | 0 | 0 | $fin->flush(); | |||
| 949 | 0 | 0 | $slurp_file = $fin->filename(); | |||
| 950 | 0 | 0 | $self->{'_temp_fh'} = $fin; # Keep object alive; auto-unlinks at DESTROY | |||
| 951 | } else { | |||||
| 952 | 11 | 32 | my $psv = File::Spec->catfile($dir, "$dbname.psv"); | |||
| 953 | 11 | 49 | if(-r $psv) { | |||
| 954 | 3 | 9 | open($fin, '<', $psv); | |||
| 955 | # Pipe separated file | |||||
| 956 | 3 | 1670 | $slurp_file = $psv; | |||
| 957 | 3 | 6 | $params->{'sep_char'} = '|'; | |||
| 958 | } else { | |||||
| 959 | # CSV or BerkeleyDB-extension file | |||||
| 960 | 8 | 8 | for my $ext (qw(csv db)) { | |||
| 961 | 11 | 27 | my $candidate = File::Spec->catfile($dir, "$dbname.$ext"); | |||
| 962 | 11 | 48 | next unless -r $candidate; | |||
| 963 | 5 | 11 | open($fin, '<', $candidate); | |||
| 964 | 5 | 1773 | $slurp_file = $candidate; | |||
| 965 | 5 | 6 | last; | |||
| 966 | } | |||||
| 967 | } | |||||
| 968 | } | |||||
| 969 | 11 | 31 | if(my $filename = $self->{'filename'} || $defaults{'filename'}) { | |||
| 970 | 1 | 3 | Carp::croak(ref($self), ": unsafe filename '$filename'") | |||
| 971 | unless $filename =~ /\A[a-zA-Z0-9_.-]+\z/ && $filename !~ /\.\./; | |||||
| 972 | 1 | 2 | $self->_debug("Looking for $filename in $dir"); | |||
| 973 | 1 | 19 | $slurp_file = File::Spec->catfile($dir, $filename); | |||
| 974 | } | |||||
| 975 | 11 | 66 | if(defined($slurp_file) && (-r $slurp_file)) { | |||
| 976 | 9 | 20 | close($fin) if(defined($fin)); | |||
| 977 | 9 | 1514 | my $sep_char = $params->{'sep_char'}; | |||
| 978 | ||||||
| 979 | 9 | 24 | $self->_debug(__LINE__, ' of ', __PACKAGE__, ": slurp_file = $slurp_file, sep_char = $sep_char"); | |||
| 980 | ||||||
| 981 | 9 | 618 | if($params->{'column_names'}) { | |||
| 982 | $dbh = DBI->connect("dbi:CSV:db_name=$slurp_file", undef, undef, | |||||
| 983 | { | |||||
| 984 | csv_sep_char => $sep_char, | |||||
| 985 | csv_tables => { | |||||
| 986 | $table => { | |||||
| 987 | 1 | 5 | col_names => $params->{'column_names'}, | |||
| 988 | }, | |||||
| 989 | }, | |||||
| 990 | f_dir => $dir, | |||||
| 991 | RaiseError => 1, | |||||
| 992 | PrintError => 0 | |||||
| 993 | } | |||||
| 994 | ); | |||||
| 995 | } else { | |||||
| 996 | 8 | 36 | $dbh = DBI->connect("dbi:CSV:db_name=$slurp_file", undef, undef, { csv_sep_char => $sep_char, f_dir => $dir, RaiseError => 1 }); | |||
| 997 | } | |||||
| 998 | 9 | 294620 | $dbh->{'RaiseError'} = 1; | |||
| 999 | ||||||
| 1000 | 9 | 62 | $self->_debug("read in $table from CSV $slurp_file"); | |||
| 1001 | ||||||
| 1002 | 9 | 704 | $dbh->{csv_tables}->{$table} = { | |||
| 1003 | allow_loose_quotes => 1, | |||||
| 1004 | blank_is_undef => 1, | |||||
| 1005 | empty_is_undef => 1, | |||||
| 1006 | binary => 1, | |||||
| 1007 | f_file => $slurp_file, | |||||
| 1008 | escape_char => '\\', | |||||
| 1009 | sep_char => $sep_char, | |||||
| 1010 | # Don't do this, causes "Bizarre copy of HASH | |||||
| 1011 | # in scalar assignment in error_diag | |||||
| 1012 | # RT121127 | |||||
| 1013 | # auto_diag => 1, | |||||
| 1014 | auto_diag => 0, | |||||
| 1015 | # Don't do this, it causes "Attempt to free unreferenced scalar" | |||||
| 1016 | # callbacks => { | |||||
| 1017 | # after_parse => sub { | |||||
| 1018 | # my ($csv, @rows) = @_; | |||||
| 1019 | # my @rc; | |||||
| 1020 | # foreach my $row(@rows) { | |||||
| 1021 | # if($row->[0] !~ /^#/) { | |||||
| 1022 | # push @rc, $row; | |||||
| 1023 | # } | |||||
| 1024 | # } | |||||
| 1025 | # return @rc; | |||||
| 1026 | # } | |||||
| 1027 | # } | |||||
| 1028 | }; | |||||
| 1029 | ||||||
| 1030 | # Text::xSV::Slurp cannot override column names, so skip slurp when | |||||
| 1031 | # column_names is set â the DBI CSV connection will supply names instead. | |||||
| 1032 | 9 | 9591 | if(((-s $slurp_file) <= $max_slurp_size) && !$params->{'column_names'}) { | |||
| 1033 | 7 | 27 | if((-s $slurp_file) == 0) { | |||
| 1034 | # Empty file | |||||
| 1035 | 0 | 0 | $self->{'data'} = (); | |||
| 1036 | } else { | |||||
| 1037 | 7 | 686 | require Text::xSV::Slurp; | |||
| 1038 | ||||||
| 1039 | 7 | 10754 | $self->_debug('slurp in'); | |||
| 1040 | ||||||
| 1041 | 7 | 678 | my $dataref = Text::xSV::Slurp::xsv_slurp( | |||
| 1042 | shape => 'aoh', | |||||
| 1043 | text_csv => { | |||||
| 1044 | sep_char => $sep_char, | |||||
| 1045 | allow_loose_quotes => 1, | |||||
| 1046 | blank_is_undef => 1, | |||||
| 1047 | empty_is_undef => 1, | |||||
| 1048 | binary => 1, | |||||
| 1049 | escape_char => '\\', | |||||
| 1050 | }, | |||||
| 1051 | # string => \join('', grep(!/^\s*(#|$)/, <DATA>)) | |||||
| 1052 | file => $slurp_file | |||||
| 1053 | ); | |||||
| 1054 | ||||||
| 1055 | # Filter out blank lines and comment rows (lines starting with #) | |||||
| 1056 | # Two passes replaced with one: pre-compute id column to avoid N hash | |||||
| 1057 | # lookups per element, and combine both conditions into one grep. | |||||
| 1058 | 7 | 1408 | my $id_col = $self->{'id'}; | |||
| 1059 | 7 39 7 | 7 60 8 | my @data = grep { defined($_->{$id_col}) && $_->{$id_col} !~ /\A\s*#/ } @{$dataref}; | |||
| 1060 | ||||||
| 1061 | 7 | 12 | if($self->{'no_entry'}) { | |||
| 1062 | # Not keyed on a primary column â keep as ordered list. | |||||
| 1063 | # Only store a reference when rows were found; an empty-array ref | |||||
| 1064 | # is truthy, which would activate the in-memory fast-path and | |||||
| 1065 | # silently return 0 results instead of falling through to SQL. | |||||
| 1066 | 2 | 7 | $self->{'data'} = @data ? \@data : undef; | |||
| 1067 | } else { | |||||
| 1068 | # Key the hash by $self->{'id'} for O(1) entry lookups | |||||
| 1069 | 5 18 | 6 28 | $self->{'data'} = { map { $_->{$self->{'id'}} => $_ } @data }; | |||
| 1070 | } | |||||
| 1071 | } | |||||
| 1072 | } | |||||
| 1073 | 9 | 32 | $self->{'type'} = 'CSV'; | |||
| 1074 | } else { | |||||
| 1075 | 2 | 5 | my $xlsx_file = File::Spec->catfile($dir, "$dbname.xlsx"); | |||
| 1076 | 2 | 7 | if(-r $xlsx_file) { | |||
| 1077 | # Excel workbook via DBD::Excel â each worksheet is a SQL table. | |||||
| 1078 | # Loaded lazily; not required for any other backend. | |||||
| 1079 | 0 | 0 | require DBD::Excel; | |||
| 1080 | 0 | 0 | $dbh = DBI->connect("dbi:Excel:file=$xlsx_file", undef, undef, { | |||
| 1081 | RaiseError => 1, | |||||
| 1082 | PrintError => 0, | |||||
| 1083 | }) or Carp::croak(ref($self), ": can't open $xlsx_file: $DBI::errstr"); | |||||
| 1084 | 0 | 0 | $self->{'type'} = 'Excel'; | |||
| 1085 | 0 | 0 | $slurp_file = $xlsx_file; | |||
| 1086 | } else { | |||||
| 1087 | 2 | 6 | $slurp_file = File::Spec->catfile($dir, "$dbname.xml"); | |||
| 1088 | 2 | 8 | if(-r $slurp_file) { | |||
| 1089 | 1 | 3 | if((-s $slurp_file) <= $max_slurp_size) { | |||
| 1090 | 1 | 337 | require XML::Simple; | |||
| 1091 | ||||||
| 1092 | 1 | 3762 | my $xml = XML::Simple::XMLin($slurp_file); | |||
| 1093 | 1 1 | 23067 2 | my @keys = keys %{$xml}; | |||
| 1094 | 1 | 1 | my $key = $keys[0]; | |||
| 1095 | 1 | 1 | my @data; | |||
| 1096 | 1 | 2 | if(ref($xml->{$key}) eq 'ARRAY') { | |||
| 1097 | 1 1 | 1 1 | @data = @{$xml->{$key}}; | |||
| 1098 | } elsif(ref($xml) eq 'ARRAY') { | |||||
| 1099 | 0 0 | 0 0 | @data = @{$xml}; | |||
| 1100 | } elsif((ref($xml) eq 'HASH') && !$self->{'no_entry'}) { | |||||
| 1101 | 0 0 | 0 0 | if(scalar(keys %{$xml}) == 1) { | |||
| 1102 | 0 | 0 | if($xml->{$table}) { | |||
| 1103 | 0 | 0 | @data = $xml->{$table}; | |||
| 1104 | } else { | |||||
| 1105 | 0 | 0 | Carp::croak('XML slurp: complex documents with an "entry" field are not yet supported'); | |||
| 1106 | } | |||||
| 1107 | } else { | |||||
| 1108 | 0 | 0 | Carp::croak('XML slurp: multi-key documents are not yet supported'); | |||
| 1109 | } | |||||
| 1110 | } else { | |||||
| 1111 | 0 | 0 | Carp::croak('XML slurp: cannot handle ', ref($xml), ' structure'); | |||
| 1112 | } | |||||
| 1113 | 1 | 2 | if($self->{'no_entry'}) { | |||
| 1114 | # Not keyed, will need to scan each entry | |||||
| 1115 | 0 | 0 | my $i = 0; | |||
| 1116 | 0 | 0 | foreach my $d(@data) { | |||
| 1117 | 0 | 0 | $self->{'data'}->{$i++} = $d; | |||
| 1118 | } | |||||
| 1119 | } else { | |||||
| 1120 | # keyed on the $self->{'id'} (default: "entry") column | |||||
| 1121 | 1 | 2 | foreach my $d(@data) { | |||
| 1122 | 5 | 7 | $self->{'data'}->{$d->{$self->{'id'}}} = $d; | |||
| 1123 | } | |||||
| 1124 | } | |||||
| 1125 | } else { | |||||
| 1126 | 0 | 0 | $dbh = DBI->connect('dbi:XMLSimple(RaiseError=>1):'); | |||
| 1127 | 0 | 0 | $dbh->{'RaiseError'} = 1; | |||
| 1128 | 0 | 0 | $self->_debug("read in $table from XML $slurp_file"); | |||
| 1129 | 0 | 0 | $dbh->func($table, 'XML', $slurp_file, 'xmlsimple_import'); | |||
| 1130 | } | |||||
| 1131 | } else { | |||||
| 1132 | # throw Error(-file => "$dir/$table"); | |||||
| 1133 | 1 | 3 | $self->_fatal("Can't find a file called '$dbname' for the table $table in $dir"); | |||
| 1134 | } | |||||
| 1135 | 1 | 2 | $self->{'type'} = 'XML'; | |||
| 1136 | } | |||||
| 1137 | } | |||||
| 1138 | } | |||||
| 1139 | ||||||
| 1140 | # ref() must be called on the variable, not on the result of 'eq' | |||||
| 1141 | 10 | 57 | $self->_fixate($self->{'data'}) if($self->{'data'} && (ref($self->{'data'}) eq 'HASH')); | |||
| 1142 | ||||||
| 1143 | 10 | 1249 | $self->{$table} = $dbh; | |||
| 1144 | 10 | 62 | my @statb = stat($slurp_file); | |||
| 1145 | 10 | 15 | $self->{'_updated'} = $statb[9]; | |||
| 1146 | ||||||
| 1147 | 10 | 23 | return $self; | |||
| 1148 | 35 35 35 | 117 31 423 | } | |||
| 1149 | ||||||
| 1150 - 1186 | =head2 selectall_arrayref
Returns a reference to an array of hash references for every row that
matches the given criteria, or C<undef> when there are no matches.
my $rows = $db->selectall_arrayref(); # all rows
my $rows = $db->selectall_arrayref(status => 'active'); # exact match
my $rows = $db->selectall_arrayref(score => { '>' => 8 }); # operator
The full criteria syntax is described in L</QUERY CRITERIA>.
Pass a C<join> key to combine with another table:
my $rows = $db->selectall_arrayref(
dept_name => 'Engineering',
join => { table => 'dept', on => 'e.dept_id = dept.id' },
);
Results are returned in the cache (if configured) and the returned array
reference is made read-only unless C<no_fixate> was set.
B<Note:> this always returns all matching rows. Use L</selectall_array>
in scalar context, or C<< $db->query->limit(1)->all() >>, to fetch just one row.
=head3 PSEUDOCODE
1. Parse criteria; extract and build any JOIN clause.
2. If data is slurped AND no joins AND criteria are simple:
a. No criteria -> return all rows as arrayref.
b. entry-only lookup -> return [$data{entry}].
c. Otherwise -> scan rows in-memory with _match_criterion.
3. Otherwise build SQL: SELECT * FROM table [JOIN] [WHERE] ORDER BY id.
4. Check cache; return cached arrayref on HIT.
5. prepare_cached + execute; fetch all rows.
6. Store result in cache; fixate the array; return arrayref.
=cut | |||||
| 1187 | ||||||
| 1188 | sub selectall_arrayref { | |||||
| 1189 | 234 | 67631 | my $self = shift; | |||
| 1190 | ||||||
| 1191 | # Fire _open() first so $self->{'berkeley'} is known before we parse @_. | |||||
| 1192 | # BerkeleyDB param parsing must use get_params(undef, \@_) so that | |||||
| 1193 | # key-value pairs like (join => {...}) are not mangled by the positional | |||||
| 1194 | # 'entry' mapping that non-BerkeleyDB paths use. | |||||
| 1195 | 234 | 396 | $self->_open_table({}); | |||
| 1196 | ||||||
| 1197 | 231 | 203 | my $params; | |||
| 1198 | ||||||
| 1199 | 231 | 302 | if($self->{'berkeley'}) { | |||
| 1200 | 12 | 56 | $params = Params::Get::get_params(undef, \@_) // {}; | |||
| 1201 | 12 | 164 | return set_return($self->_scan_berkeley($params), { type => 'arrayref' }); | |||
| 1202 | } | |||||
| 1203 | ||||||
| 1204 | 219 | 329 | if($self->{'no_entry'}) { | |||
| 1205 | 129 | 206 | $params = Params::Get::get_params(undef, \@_); | |||
| 1206 | } elsif(scalar(@_)) { | |||||
| 1207 | 36 | 46 | $params = Params::Get::get_params('entry', @_); | |||
| 1208 | } | |||||
| 1209 | ||||||
| 1210 | 219 | 2342 | my $table = $self->_open_table($params); | |||
| 1211 | ||||||
| 1212 | 219 | 328 | $params //= {}; | |||
| 1213 | ||||||
| 1214 | 219 | 199 | my $join_clause = ''; | |||
| 1215 | 219 | 273 | if(my $join_spec = delete $params->{'join'}) { | |||
| 1216 | 38 | 68 | $join_clause = $self->_build_joins($join_spec); | |||
| 1217 | } | |||||
| 1218 | ||||||
| 1219 | 202 | 513 | if(!$join_clause && $self->{'data'} && !$self->_has_complex_criteria($params)) { | |||
| 1220 | 74 74 | 50 81 | if(scalar(keys %{$params}) == 0) { | |||
| 1221 | 48 | 90 | $self->_trace("$table: selectall_arrayref fast track return"); | |||
| 1222 | 48 | 1003 | if(ref($self->{'data'}) eq 'HASH') { | |||
| 1223 | 45 45 | 49 89 | $self->_debug("$table: returning ", scalar keys %{$self->{'data'}}, ' entries'); | |||
| 1224 | 45 45 | 788 65 | if(scalar keys %{$self->{'data'}} <= 10) { | |||
| 1225 | 45 45 45 | 37 102 115 | $self->_debug(do { require Data::Dumper; Data::Dumper::Dumper($self->{'data'}) }); | |||
| 1226 | } | |||||
| 1227 | 45 45 | 708 66 | my @rc = values %{$self->{'data'}}; | |||
| 1228 | 45 | 108 | return set_return(\@rc, { type => 'arrayref' }); | |||
| 1229 | } | |||||
| 1230 | 3 | 11 | return set_return($self->{'data'}, { type => 'arrayref'}); | |||
| 1231 | 26 | 85 | } elsif((scalar(keys %{$params}) == 1) && defined($params->{'entry'}) && !$self->{'no_entry'}) { | |||
| 1232 | # exists() guard: fixate() locks all keys in the slurp hash; return [] | |||||
| 1233 | # (not [undef]) when the key is missing so callers get an empty result | |||||
| 1234 | return set_return([], { type => 'arrayref' }) | |||||
| 1235 | 14 | 30 | unless exists($self->{'data'}->{$params->{'entry'}}); | |||
| 1236 | 8 | 25 | return set_return([$self->{'data'}->{$params->{'entry'}}], { type => 'arrayref' }); | |||
| 1237 | } elsif(ref($self->{'data'}) eq 'HASH') { | |||||
| 1238 | # Scan in-memory hash for simple column criteria without touching DBI. | |||||
| 1239 | # fixate() locks hash keys, so use exists() to avoid throwing on unknown columns. | |||||
| 1240 | 12 | 22 | $self->_debug("$table: selectall_arrayref in-memory scan with criteria"); | |||
| 1241 | # Pre-compute param keys once â avoids re-running keys() inside the inner | |||||
| 1242 | # closure on every row iteration (N hash-key extractions â 1). | |||||
| 1243 | 12 12 | 246 14 | my @param_keys = keys %{$params}; | |||
| 1244 | my @rc = grep { | |||||
| 1245 | 47 | 33 | my $row = $_; | |||
| 1246 | 47 | 75 | all { $self->_match_criterion(exists($row->{$_}) ? $row->{$_} : undef, $params->{$_}) } @param_keys | |||
| 1247 | 12 47 12 | 9 76 15 | } values %{$self->{'data'}}; | |||
| 1248 | 12 | 24 | return set_return(\@rc, { type => 'arrayref' }); | |||
| 1249 | } | |||||
| 1250 | } | |||||
| 1251 | ||||||
| 1252 | 128 | 225 | my ($where, $wargs) = $self->_build_where($params); | |||
| 1253 | 118 118 | 96 111 | my @query_args = @{$wargs}; | |||
| 1254 | ||||||
| 1255 | 118 | 107 | my $query = "SELECT * FROM $table"; | |||
| 1256 | 118 | 121 | $query .= " $join_clause" if $join_clause; | |||
| 1257 | 118 | 215 | if($join_clause) { | |||
| 1258 | 20 | 24 | $query .= " WHERE $where" if $where; | |||
| 1259 | } elsif(($self->{'type'} eq 'CSV') && !$self->{'no_entry'}) { | |||||
| 1260 | 10 | 13 | my $id = $self->{'id'}; | |||
| 1261 | 10 | 19 | $query .= " WHERE $id IS NOT NULL AND $id NOT LIKE '#%'"; | |||
| 1262 | 10 | 16 | $query .= " AND ($where)" if $where; | |||
| 1263 | } else { | |||||
| 1264 | 88 | 98 | $query .= " WHERE $where" if $where; | |||
| 1265 | } | |||||
| 1266 | 118 | 145 | if(!$self->{'no_entry'}) { | |||
| 1267 | 14 | 37 | $query .= ' ORDER BY ' . $self->{'id'}; | |||
| 1268 | } | |||||
| 1269 | ||||||
| 1270 | 118 | 113 | if(defined($query_args[0])) { | |||
| 1271 | 76 | 186 | $self->_debug("selectall_arrayref $query: ", join(', ', @query_args)); | |||
| 1272 | } else { | |||||
| 1273 | 42 | 74 | $self->_debug("selectall_arrayref $query"); | |||
| 1274 | } | |||||
| 1275 | ||||||
| 1276 | 118 | 2829 | my $key; | |||
| 1277 | my $c; | |||||
| 1278 | 118 | 137 | if($c = $self->{cache}) { | |||
| 1279 | 0 | 0 | $key = ref($self) . "::$query array"; | |||
| 1280 | 0 | 0 | if(defined($query_args[0])) { | |||
| 1281 | 0 | 0 | $key .= ' ' . join(', ', @query_args); | |||
| 1282 | } | |||||
| 1283 | 0 | 0 | $self->_debug("cache key = '$key'"); | |||
| 1284 | 0 | 0 | if(my $rc = $c->get($key)) { | |||
| 1285 | 0 | 0 | $self->_debug('cache HIT'); | |||
| 1286 | 0 | 0 | return $rc; # We stored a ref to the array | |||
| 1287 | ||||||
| 1288 | # This use of a temporary variable is to avoid | |||||
| 1289 | # "Implicit scalar context for array in return" | |||||
| 1290 | # my @rc = @{$rc}; | |||||
| 1291 | # return @rc; | |||||
| 1292 | } | |||||
| 1293 | 0 | 0 | $self->_debug('cache MISS'); | |||
| 1294 | } else { | |||||
| 1295 | 118 | 131 | $self->_debug('cache not used'); | |||
| 1296 | } | |||||
| 1297 | ||||||
| 1298 | 118 | 2270 | if(my $sth = $self->{$table}->prepare_cached($query)) { | |||
| 1299 | 115 | 32805 | $sth->execute(@query_args) || croak("$query: @query_args"); | |||
| 1300 | ||||||
| 1301 | 109 | 28957 | my $rc; | |||
| 1302 | 109 | 1010 | while(my $href = $sth->fetchrow_hashref()) { | |||
| 1303 | 268 268 268 | 1680 1210 241 | push @{$rc}, $href if %{$href}; | |||
| 1304 | } | |||||
| 1305 | 109 | 441 | $c->set($key, $rc, $self->{'cache_duration'}) if $c; | |||
| 1306 | ||||||
| 1307 | 109 | 218 | if($rc && !$self->{'no_fixate'}) { | |||
| 1308 | 97 | 174 | $self->_fixate($rc); | |||
| 1309 | } | |||||
| 1310 | ||||||
| 1311 | 109 | 15372 | return $rc; | |||
| 1312 | } | |||||
| 1313 | 0 | 0 | $self->_warn("selectall_arrayref failure on $query: @query_args"); | |||
| 1314 | 0 | 0 | croak("$query: @query_args"); | |||
| 1315 | } | |||||
| 1316 | ||||||
| 1317 - 1322 | =head2 selectall_hashref Deprecated alias for L</selectall_arrayref>. Use C<selectall_arrayref> in new code. =cut | |||||
| 1323 | ||||||
| 1324 | sub selectall_hashref | |||||
| 1325 | { | |||||
| 1326 | 8 | 1286 | my $self = shift; | |||
| 1327 | 8 | 24 | return $self->selectall_arrayref(@_); | |||
| 1328 | } | |||||
| 1329 | ||||||
| 1330 - 1343 | =head2 selectall_array Similar to L</selectall_arrayref> but returns a list of hash references rather than a reference to an array. my @rows = $db->selectall_array(status => 'active'); In B<scalar context> it applies C<LIMIT 1> and returns just the first matching hash reference - making it more efficient than C<selectall_arrayref> when you only need one row. In B<list context> all matching rows are returned. Accepts the same criteria and C<join> parameter as L</selectall_arrayref>. =cut | |||||
| 1344 | ||||||
| 1345 | sub selectall_array | |||||
| 1346 | { | |||||
| 1347 | 41 | 8084 | my $self = shift; | |||
| 1348 | ||||||
| 1349 | 41 | 79 | $self->_open_table({}); | |||
| 1350 | ||||||
| 1351 | 41 | 68 | if($self->{'berkeley'}) { | |||
| 1352 | 3 | 6 | my $params = Params::Get::get_params(undef, \@_) // {}; | |||
| 1353 | 3 | 35 | my $rows = $self->_scan_berkeley($params); | |||
| 1354 | 3 2 | 5 4 | return wantarray ? @{$rows} : $rows->[0]; | |||
| 1355 | } | |||||
| 1356 | ||||||
| 1357 | 38 | 100 | my $params = Params::Get::get_params(undef, \@_); | |||
| 1358 | 38 | 473 | my $table = $self->_open_table($params); | |||
| 1359 | ||||||
| 1360 | 38 | 92 | $params //= {}; | |||
| 1361 | 38 | 37 | my $join_clause = ''; | |||
| 1362 | 38 | 60 | if(my $join_spec = delete $params->{'join'}) { | |||
| 1363 | 1 | 2 | $join_clause = $self->_build_joins($join_spec); | |||
| 1364 | } | |||||
| 1365 | ||||||
| 1366 | 38 | 130 | if(!$join_clause && $self->{'data'} && !$self->_has_complex_criteria($params)) { | |||
| 1367 | 30 30 | 29 41 | if(scalar(keys %{$params}) == 0) { | |||
| 1368 | 16 | 33 | $self->_trace("$table: selectall_array fast track return"); | |||
| 1369 | 16 | 338 | if(ref($self->{'data'}) eq 'HASH') { | |||
| 1370 | 15 15 | 15 45 | return values %{$self->{'data'}}; | |||
| 1371 | } | |||||
| 1372 | 1 1 | 1 3 | return @{$self->{'data'}}; | |||
| 1373 | 14 | 43 | } elsif((scalar(keys %{$params}) == 1) && defined($params->{'entry'}) && !$self->{'no_entry'}) { | |||
| 1374 | # exists() guard: fixate() locks all keys; return empty list (not undef) | |||||
| 1375 | # for a missing entry so callers in list context get 0 elements not 1 | |||||
| 1376 | 10 | 23 | return () unless exists($self->{'data'}->{$params->{'entry'}}); | |||
| 1377 | 5 | 11 | return $self->{'data'}->{$params->{'entry'}}; | |||
| 1378 | } elsif(ref($self->{'data'}) eq 'HASH') { | |||||
| 1379 | # Same as selectall_arrayref scan but returns a list | |||||
| 1380 | 4 | 9 | $self->_debug("$table: selectall_array in-memory scan with criteria"); | |||
| 1381 | # Pre-compute param keys once â same optimisation as selectall_arrayref: | |||||
| 1382 | # avoids N * K hash-key extractions inside the inner closure. | |||||
| 1383 | 4 4 | 98 21 | my @param_keys = keys %{$params}; | |||
| 1384 | my @rc = grep { | |||||
| 1385 | 16 | 10 | my $row = $_; | |||
| 1386 | 16 | 27 | all { $self->_match_criterion(exists($row->{$_}) ? $row->{$_} : undef, $params->{$_}) } @param_keys | |||
| 1387 | 4 16 4 | 7 26 7 | } values %{$self->{'data'}}; | |||
| 1388 | 4 | 9 | return @rc; | |||
| 1389 | } | |||||
| 1390 | } | |||||
| 1391 | ||||||
| 1392 | 8 | 15 | my ($where, $wargs) = $self->_build_where($params); | |||
| 1393 | 8 8 | 8 10 | my @query_args = @{$wargs}; | |||
| 1394 | ||||||
| 1395 | 8 | 11 | my $query = "SELECT * FROM $table"; | |||
| 1396 | 8 | 13 | $query .= " $join_clause" if $join_clause; | |||
| 1397 | 8 | 31 | if($join_clause) { | |||
| 1398 | 1 | 2 | $query .= " WHERE $where" if $where; | |||
| 1399 | } elsif(($self->{'type'} eq 'CSV') && !$self->{'no_entry'}) { | |||||
| 1400 | 2 | 3 | my $id = $self->{'id'}; | |||
| 1401 | 2 | 3 | $query .= " WHERE $id IS NOT NULL AND $id NOT LIKE '#%'"; | |||
| 1402 | 2 | 3 | $query .= " AND ($where)" if $where; | |||
| 1403 | } else { | |||||
| 1404 | 5 | 10 | $query .= " WHERE $where" if $where; | |||
| 1405 | } | |||||
| 1406 | 8 | 40 | if(!$self->{'no_entry'}) { | |||
| 1407 | 5 | 8 | $query .= ' ORDER BY ' . $self->{'id'}; | |||
| 1408 | } | |||||
| 1409 | 8 | 16 | if(!wantarray) { | |||
| 1410 | 3 | 4 | $query .= ' LIMIT 1'; | |||
| 1411 | } | |||||
| 1412 | ||||||
| 1413 | 8 | 32 | if(defined($query_args[0])) { | |||
| 1414 | 2 | 6 | $self->_debug("selectall_array $query: ", join(', ', @query_args)); | |||
| 1415 | } else { | |||||
| 1416 | 6 | 11 | $self->_debug("selectall_array $query"); | |||
| 1417 | } | |||||
| 1418 | ||||||
| 1419 | 8 | 164 | my $key; | |||
| 1420 | my $c; | |||||
| 1421 | 8 | 15 | if($c = $self->{cache}) { | |||
| 1422 | 0 | 0 | $key = ref($self) . '::' . $query; | |||
| 1423 | 0 | 0 | if(wantarray) { | |||
| 1424 | 0 | 0 | $key .= ' array'; | |||
| 1425 | } | |||||
| 1426 | 0 | 0 | if(defined($query_args[0])) { | |||
| 1427 | 0 | 0 | $key .= ' ' . join(', ', @query_args); | |||
| 1428 | } | |||||
| 1429 | 0 | 0 | $self->_debug("cache key = '$key'"); | |||
| 1430 | 0 | 0 | if(my $rc = $c->get($key)) { | |||
| 1431 | 0 | 0 | $self->_debug('cache HIT'); | |||
| 1432 | 0 0 | 0 0 | return wantarray ? @{$rc} : $rc; # We stored a ref to the array | |||
| 1433 | ||||||
| 1434 | # This use of a temporary variable is to avoid | |||||
| 1435 | # "Implicit scalar context for array in return" | |||||
| 1436 | # my @rc = @{$rc}; | |||||
| 1437 | # return @rc; | |||||
| 1438 | } | |||||
| 1439 | 0 | 0 | $self->_debug('cache MISS'); | |||
| 1440 | } else { | |||||
| 1441 | 8 | 14 | $self->_debug('cache not used'); | |||
| 1442 | } | |||||
| 1443 | ||||||
| 1444 | 8 | 131 | if(my $sth = $self->{$table}->prepare_cached($query)) { | |||
| 1445 | 8 | 5460 | $sth->execute(@query_args) || croak("$query: @query_args"); | |||
| 1446 | ||||||
| 1447 | 8 | 7796 | my $rc; | |||
| 1448 | 8 | 60 | while(my $href = $sth->fetchrow_hashref()) { | |||
| 1449 | 30 | 552 | if(!wantarray) { | |||
| 1450 | # Scalar context: return just the first row; cache it too | |||||
| 1451 | 3 | 6 | $sth->finish(); | |||
| 1452 | 3 | 7 | $c->set($key, [$href], $self->{'cache_duration'}) if $c; | |||
| 1453 | 3 | 9 | return $href; | |||
| 1454 | } | |||||
| 1455 | 27 27 | 19 66 | push @{$rc}, $href; | |||
| 1456 | } | |||||
| 1457 | 5 | 64 | $c->set($key, $rc, $self->{'cache_duration'}) if $c; | |||
| 1458 | ||||||
| 1459 | 5 | 14 | if($rc) { | |||
| 1460 | 5 | 10 | if(!$self->{'no_fixate'}) { | |||
| 1461 | 5 | 16 | $self->_fixate($rc); | |||
| 1462 | } | |||||
| 1463 | 5 5 | 1079 19 | return @{$rc}; | |||
| 1464 | } | |||||
| 1465 | 0 | 0 | return; | |||
| 1466 | } | |||||
| 1467 | 0 | 0 | $self->_warn("selectall_array failure on $query: @query_args"); | |||
| 1468 | 0 | 0 | croak("$query: @query_args"); | |||
| 1469 | } | |||||
| 1470 | ||||||
| 1471 - 1476 | =head2 selectall_hash Deprecated alias for L</selectall_array>. Use C<selectall_array> in new code. =cut | |||||
| 1477 | ||||||
| 1478 | sub selectall_hash | |||||
| 1479 | { | |||||
| 1480 | 9 | 3074 | my $self = shift; | |||
| 1481 | 9 | 37 | return $self->selectall_array(@_); | |||
| 1482 | } | |||||
| 1483 | ||||||
| 1484 - 1494 | =head2 count
Returns the number of rows matching the given criteria.
my $total = $db->count();
my $active = $db->count(status => 'active');
my $high = $db->count(score => { '>' => 90 });
Accepts the full criteria syntax described in L</QUERY CRITERIA>.
=cut | |||||
| 1495 | ||||||
| 1496 | sub count | |||||
| 1497 | { | |||||
| 1498 | 195 | 12453 | my $self = shift; | |||
| 1499 | ||||||
| 1500 | 195 | 344 | $self->_open_table({}); | |||
| 1501 | ||||||
| 1502 | 171 | 240 | if($self->{'berkeley'}) { | |||
| 1503 | 4 | 7 | my $params = Params::Get::get_params(undef, \@_) // {}; | |||
| 1504 | 4 4 | 46 7 | return scalar @{$self->_scan_berkeley($params)}; | |||
| 1505 | } | |||||
| 1506 | ||||||
| 1507 | 167 | 289 | my $params = Params::Get::get_params(undef, \@_); | |||
| 1508 | 167 | 1831 | my $table = $self->_open_table($params); | |||
| 1509 | ||||||
| 1510 | 167 | 231 | if($self->{'data'}) { | |||
| 1511 | 130 130 | 75 167 | if(scalar(keys %{$params}) == 0) { | |||
| 1512 | 114 | 214 | $self->_trace("$table: count fast track return"); | |||
| 1513 | 114 | 2419 | if(ref($self->{'data'}) eq 'HASH') { | |||
| 1514 | 102 102 | 67 225 | return scalar keys %{$self->{'data'}}; | |||
| 1515 | } | |||||
| 1516 | 12 12 | 12 27 | return scalar @{$self->{'data'}}; | |||
| 1517 | 16 | 74 | } elsif((scalar(keys %{$params}) == 1) && defined($params->{'entry'}) && !$self->{'no_entry'}) { | |||
| 1518 | # exists() guard: fixate() locks all keys in the slurp hash | |||||
| 1519 | 9 | 45 | return (exists($self->{'data'}->{$params->{'entry'}}) && $self->{'data'}->{$params->{'entry'}}) ? 1 : 0; | |||
| 1520 | } elsif(!$self->_has_complex_criteria($params) && !$self->{$table}) { | |||||
| 1521 | # General in-memory scan for simple column criteria. | |||||
| 1522 | # Only taken when there is no DBI handle ($self->{$table} is undef), | |||||
| 1523 | # i.e. slurp-only backends like Deep. CSV/XML/SQLite have a DBI handle | |||||
| 1524 | # and must fall through to the SQL path so that column-name validation | |||||
| 1525 | # fires in _build_where_conditions. | |||||
| 1526 | 0 | 0 | $self->_debug("$table: count in-memory scan"); | |||
| 1527 | 0 0 | 0 0 | my @param_keys = keys %{$params}; | |||
| 1528 | # Pass the row list directly to grep â avoids materialising an | |||||
| 1529 | # intermediate @rows array of N references on the stack. | |||||
| 1530 | return scalar grep { | |||||
| 1531 | 0 | 0 | my $row = $_; | |||
| 1532 | 0 | 0 | all { $self->_match_criterion(exists($row->{$_}) ? $row->{$_} : undef, $params->{$_}) } @param_keys | |||
| 1533 | 0 0 0 0 | 0 0 0 0 | } (ref($self->{'data'}) eq 'HASH' ? values %{$self->{'data'}} : @{$self->{'data'}}); | |||
| 1534 | } | |||||
| 1535 | } | |||||
| 1536 | ||||||
| 1537 | 44 | 94 | my ($where, $wargs) = $self->_build_where($params); | |||
| 1538 | 40 40 | 49 41 | my @query_args = @{$wargs}; | |||
| 1539 | ||||||
| 1540 | 40 | 36 | my $query; | |||
| 1541 | 40 | 104 | if(($self->{'type'} eq 'CSV') && !$self->{'no_entry'}) { | |||
| 1542 | 17 | 16 | my $id = $self->{'id'}; | |||
| 1543 | 17 | 25 | $query = "SELECT COUNT(*) FROM $table WHERE $id IS NOT NULL AND $id NOT LIKE '#%'"; | |||
| 1544 | 17 | 25 | $query .= " AND ($where)" if $where; | |||
| 1545 | } elsif($self->{'no_entry'}) { | |||||
| 1546 | 19 | 20 | $query = "SELECT COUNT(*) FROM $table"; | |||
| 1547 | 19 | 35 | $query .= " WHERE $where" if $where; | |||
| 1548 | } else { | |||||
| 1549 | 4 | 7 | $query = "SELECT COUNT(" . $self->{'id'} . ") FROM $table"; | |||
| 1550 | 4 | 5 | $query .= " WHERE $where" if $where; | |||
| 1551 | } | |||||
| 1552 | ||||||
| 1553 | 40 | 52 | if(defined($query_args[0])) { | |||
| 1554 | 15 | 35 | $self->_debug("count $query: ", join(', ', @query_args)); | |||
| 1555 | } else { | |||||
| 1556 | 25 | 42 | $self->_debug("count $query"); | |||
| 1557 | } | |||||
| 1558 | ||||||
| 1559 | 40 | 852 | my $key; | |||
| 1560 | my $c; | |||||
| 1561 | 40 | 57 | if($c = $self->{'cache'}) { | |||
| 1562 | # Opportunistic: if a selectall_arrayref for the same criteria is already | |||||
| 1563 | # in cache, derive the count from that array rather than hitting the DB. | |||||
| 1564 | # The key is built to match what selectall_arrayref would store. | |||||
| 1565 | 0 | 0 | $key = ref($self) . '::' . $query; | |||
| 1566 | # [^)]+ is a negated character class: O(n) with zero backtracking. | |||||
| 1567 | # The former lazy .+? could scan past the first ) in pathological SQL; | |||||
| 1568 | # [^)]+ is also semantically correct (COUNT(expr) never contains ) ). | |||||
| 1569 | 0 | 0 | $key =~ s/COUNT\(([^)]+)\)/$1/; | |||
| 1570 | 0 | 0 | $key .= ' array'; | |||
| 1571 | 0 | 0 | if(defined($query_args[0])) { | |||
| 1572 | 0 | 0 | $key .= ' ' . join(', ', @query_args); | |||
| 1573 | } | |||||
| 1574 | 0 | 0 | if(my $rc = $c->get($key)) { | |||
| 1575 | 0 | 0 | $self->_debug('count: cache HIT (selectall array)'); | |||
| 1576 | 0 0 | 0 0 | return ref($rc) eq 'ARRAY' ? scalar @{$rc} : 0; | |||
| 1577 | } | |||||
| 1578 | 0 | 0 | $self->_debug('count: cache MISS'); | |||
| 1579 | } else { | |||||
| 1580 | 40 | 48 | $self->_debug('cache not used'); | |||
| 1581 | } | |||||
| 1582 | ||||||
| 1583 | 40 | 733 | if(my $sth = $self->{$table}->prepare_cached($query)) { | |||
| 1584 | 40 | 42183 | $sth->execute(@query_args) || croak("$query: @query_args"); | |||
| 1585 | ||||||
| 1586 | 40 | 24781 | my $count = $sth->fetchrow_arrayref()->[0]; | |||
| 1587 | 40 | 488 | $sth->finish(); | |||
| 1588 | ||||||
| 1589 | 40 | 188 | return $count; | |||
| 1590 | } | |||||
| 1591 | 0 | 0 | $self->_warn("count failure on $query: @query_args"); | |||
| 1592 | 0 | 0 | croak("$query: @query_args"); | |||
| 1593 | } | |||||
| 1594 | ||||||
| 1595 - 1619 | =head2 fetchrow_hashref
Returns a hash reference for the first row matching the given criteria,
or C<undef> when there is no match. Always applies C<LIMIT 1>.
my $row = $db->fetchrow_hashref(entry => 'key1');
my $row = $db->fetchrow_hashref(score => { '>=' => 10 });
When C<no_entry> is B<not> set you may pass a single bare value and it is
used as the C<entry> key:
my $row = $db->fetchrow_hashref('key1'); # same as entry => 'key1'
Accepts the full criteria syntax described in L</QUERY CRITERIA>, including
the C<join> parameter:
my $row = $db->fetchrow_hashref(
name => 'Alice',
join => { table => 'dept', on => 'e.dept_id = dept.id' },
);
Pass C<< table => $other_table >> to query a table other than the one
derived from the class name.
=cut | |||||
| 1620 | ||||||
| 1621 | sub fetchrow_hashref { | |||||
| 1622 | 70 | 16751 | my $self = shift; | |||
| 1623 | ||||||
| 1624 | 70 | 129 | $self->_trace('Entering fetchrow_hashref'); | |||
| 1625 | ||||||
| 1626 | 70 | 1521 | my $params; | |||
| 1627 | ||||||
| 1628 | 70 | 129 | if(!$self->{'no_entry'}) { | |||
| 1629 | 57 | 98 | $params = Params::Get::get_params('entry', @_); | |||
| 1630 | } else { | |||||
| 1631 | 13 | 23 | $params = Params::Get::get_params(undef, @_); | |||
| 1632 | } | |||||
| 1633 | ||||||
| 1634 | 70 | 1028 | my $table = $self->_open_table($params); | |||
| 1635 | ||||||
| 1636 | # ::diag($self->{'type'}); | |||||
| 1637 | 70 52 | 189 190 | if($self->{'data'} && (!$self->{'no_entry'}) && (scalar keys(%{$params}) == 1) && defined($params->{'entry'}) && !$self->_has_complex_criteria($params)) { | |||
| 1638 | 46 | 63 | $self->_debug('Fast return from slurped data'); | |||
| 1639 | # Use exists(), fixate() locks the outer hash; accessing a missing key throws | |||||
| 1640 | 46 | 892 | return exists($self->{'data'}->{$params->{'entry'}}) ? $self->{'data'}->{$params->{'entry'}} : undef; | |||
| 1641 | } | |||||
| 1642 | ||||||
| 1643 | 24 | 39 | if($self->{'berkeley'}) { | |||
| 1644 | # print STDERR ">>>>>>>>>>>>\n"; | |||||
| 1645 | # ::diag(Data::Dumper->new([$self->{'berkeley'}])->Dump()); | |||||
| 1646 | 1 1 | 2 5 | if((!$self->{'no_entry'}) && (scalar keys(%{$params}) == 1) && defined($params->{'entry'})) { | |||
| 1647 | 0 | 0 | return { entry => $self->{'berkeley'}->{$params->{'entry'}} }; | |||
| 1648 | } | |||||
| 1649 | 1 | 1 | my $id = $self->{'id'}; | |||
| 1650 | 1 0 | 2 0 | if($self->{'no_entry'} && (scalar keys(%{$params}) == 1) && defined($id) && defined($params->{$id})) { | |||
| 1651 | 0 | 0 | if(my $rc = $self->{'berkeley'}->{$params->{$id}}) { | |||
| 1652 | 0 | 0 | return { $params->{$id} => $rc } # Return key->value as a hash pair | |||
| 1653 | } | |||||
| 1654 | 0 | 0 | return; | |||
| 1655 | } | |||||
| 1656 | 1 | 13 | Carp::croak(ref($self), ': fetchrow_hashref is meaningless on a NoSQL database'); | |||
| 1657 | } | |||||
| 1658 | ||||||
| 1659 | 23 | 62 | my $target = delete($params->{'table'}) // $table; | |||
| 1660 | 23 | 25 | my $join_spec = delete $params->{'join'}; | |||
| 1661 | 23 | 34 | my $join_clause = $join_spec ? $self->_build_joins($join_spec) : ''; | |||
| 1662 | 23 | 52 | my ($where, $wargs) = $self->_build_where($params); | |||
| 1663 | 21 21 | 20 27 | my @query_args = @{$wargs}; | |||
| 1664 | ||||||
| 1665 | 21 | 24 | my $query = "SELECT * FROM $target"; | |||
| 1666 | 21 | 29 | $query .= " $join_clause" if $join_clause; | |||
| 1667 | 21 | 56 | if($join_clause) { | |||
| 1668 | 1 | 2 | $query .= " WHERE $where" if $where; | |||
| 1669 | } elsif(($self->{'type'} eq 'CSV') && !$self->{'no_entry'}) { | |||||
| 1670 | 5 | 6 | my $id = $self->{'id'}; | |||
| 1671 | 5 | 9 | $query .= " WHERE $id IS NOT NULL AND $id NOT LIKE '#%'"; | |||
| 1672 | 5 | 12 | $query .= " AND ($where)" if $where; | |||
| 1673 | } else { | |||||
| 1674 | 15 | 21 | $query .= " WHERE $where" if $where; | |||
| 1675 | } | |||||
| 1676 | 21 | 35 | $query .= ' LIMIT 1'; | |||
| 1677 | 21 | 28 | if(defined($query_args[0])) { | |||
| 1678 | 20 | 53 | my @call_details = caller(0); | |||
| 1679 | 20 | 192 | $self->_debug("fetchrow_hashref $query: ", join(', ', @query_args), | |||
| 1680 | ' called from ', $call_details[2], ' of ', $call_details[1]); | |||||
| 1681 | } else { | |||||
| 1682 | 1 | 2 | $self->_debug("fetchrow_hashref $query"); | |||
| 1683 | } | |||||
| 1684 | # TODO: Data Flow Anomaly - D~: $key is computed unconditionally (string concat + | |||||
| 1685 | # join) even when no cache is configured. When $self->{cache} is undef the | |||||
| 1686 | # assembled string is a dead store. Cost is trivial but the logic would be | |||||
| 1687 | # cleaner inside the if($c) block below. | |||||
| 1688 | 21 | 435 | my $key = ref($self) . '::'; | |||
| 1689 | 21 | 34 | if(defined($query_args[0])) { | |||
| 1690 | 20 | 26 | if(wantarray) { | |||
| 1691 | 0 | 0 | $key .= 'array '; | |||
| 1692 | } | |||||
| 1693 | 20 | 64 | $key .= "fetchrow $query " . join(', ', @query_args); | |||
| 1694 | } else { | |||||
| 1695 | 1 | 1 | $key .= "fetchrow $query"; | |||
| 1696 | } | |||||
| 1697 | 21 | 17 | my $c; | |||
| 1698 | 21 | 31 | if($c = $self->{cache}) { | |||
| 1699 | 0 | 0 | if(my $rc = $c->get($key)) { | |||
| 1700 | 0 | 0 | if(wantarray) { | |||
| 1701 | 0 | 0 | if(ref($rc) eq 'ARRAY') { | |||
| 1702 | 0 0 | 0 0 | return @{$rc}; # We stored a ref to the array | |||
| 1703 | } | |||||
| 1704 | } else { | |||||
| 1705 | 0 | 0 | return $rc; | |||
| 1706 | } | |||||
| 1707 | } | |||||
| 1708 | } | |||||
| 1709 | ||||||
| 1710 | my $sth = $self->{$table}->prepare_cached($query) | |||||
| 1711 | 21 | 107 | or Carp::croak(ref($self), ": prepare failed: ", $self->{$table}->errstr()); | |||
| 1712 | 21 | 19758 | $sth->execute(@query_args) || croak("$query: @query_args"); | |||
| 1713 | 21 | 8973 | my $rc = $sth->fetchrow_hashref(); | |||
| 1714 | 21 | 369 | $sth->finish(); | |||
| 1715 | 21 | 52 | if($c) { | |||
| 1716 | 0 | 0 | if($rc) { | |||
| 1717 | 0 | 0 | $self->_debug("stash $key=>$rc in the cache for ", $self->{'cache_duration'}); | |||
| 1718 | 0 0 0 | 0 0 0 | $self->_debug("returns ", do { require Data::Dumper; Data::Dumper->new([$rc])->Dump() }); | |||
| 1719 | } else { | |||||
| 1720 | 0 | 0 | $self->_debug("Stash $key=>undef in the cache for ", $self->{'cache_duration'}); | |||
| 1721 | } | |||||
| 1722 | 0 | 0 | $c->set($key, $rc, $self->{'cache_duration'}); | |||
| 1723 | } | |||||
| 1724 | 21 | 80 | return $rc; | |||
| 1725 | } | |||||
| 1726 | ||||||
| 1727 - 1748 | =head2 execute Execute a raw SQL query on the underlying database. # Scalar context: returns the first row as a hashref my $row = $db->execute(query => 'SELECT * FROM foo WHERE id = 1'); # List context: returns all rows as a list of hashrefs my @rows = $db->execute(query => 'SELECT * FROM foo WHERE score > ?', args => [80]); The C<FROM E<lt>tableE<gt>> clause is appended automatically if omitted. On CSV tables without C<no_entry> it may help to add C<WHERE entry IS NOT NULL AND entry NOT LIKE '#%'> to filter comment rows. If the data have been slurped into memory this method still hits the actual database file directly. C<args> is an arrayref of bind values (see L<DBI/execute>). =cut | |||||
| 1749 | ||||||
| 1750 | sub execute | |||||
| 1751 | { | |||||
| 1752 | 18 | 4210 | my $self = shift; | |||
| 1753 | ||||||
| 1754 | 18 | 35 | if($self->{'berkeley'}) { | |||
| 1755 | 1 | 13 | Carp::croak(ref($self), ': execute is meaningless on a NoSQL database'); | |||
| 1756 | } | |||||
| 1757 | ||||||
| 1758 | 17 | 31 | my $args = Params::Get::get_params('query', @_); | |||
| 1759 | ||||||
| 1760 | # Ensure the 'query' parameter is provided | |||||
| 1761 | Carp::croak(__PACKAGE__, ': Usage: execute(query => $query)') | |||||
| 1762 | 15 | 191 | unless defined $args->{'query'}; | |||
| 1763 | ||||||
| 1764 | 15 | 25 | my $table = $self->_open_table($args); | |||
| 1765 | ||||||
| 1766 | 15 | 21 | my $query = $args->{'query'}; | |||
| 1767 | ||||||
| 1768 | # Append "FROM <table>" if missing | |||||
| 1769 | # \bFROM\b catches the keyword at any word boundary (space, tab, newline), | |||||
| 1770 | # unlike the former \sFROM\s which missed forms like "col\tFROM" or leading FROM. | |||||
| 1771 | 15 | 41 | $query .= " FROM $table" unless $query =~ /\bFROM\b/i; | |||
| 1772 | ||||||
| 1773 | # Log the query if a logger is available | |||||
| 1774 | 15 | 35 | $self->_debug("execute $query"); | |||
| 1775 | ||||||
| 1776 | # Prepare and execute the query | |||||
| 1777 | 15 | 359 | my $sth = $self->{$table}->prepare_cached($query); | |||
| 1778 | # DBI->execute() takes a list; normalise args to an array whether it | |||||
| 1779 | # was passed as an arrayref ([30]) or a bare scalar/list (30). | |||||
| 1780 | 15 | 2381 | if(exists($args->{'args'})) { | |||
| 1781 | 9 5 | 13 8 | my @bind = ref($args->{'args'}) eq 'ARRAY' ? @{$args->{'args'}} : ($args->{'args'}); | |||
| 1782 | 9 | 149 | $sth->execute(@bind) or croak("$query: ", join(', ', @bind)); | |||
| 1783 | } else { | |||||
| 1784 | 6 | 99 | $sth->execute() or croak($query); | |||
| 1785 | } | |||||
| 1786 | ||||||
| 1787 | # Fetch the results | |||||
| 1788 | 15 | 2897 | my @results; | |||
| 1789 | 15 | 120 | while (my $row = $sth->fetchrow_hashref()) { | |||
| 1790 | 31 | 277 | unless(wantarray) { | |||
| 1791 | 3 | 9 | $sth->finish(); | |||
| 1792 | 3 | 7 | return $row; | |||
| 1793 | } | |||||
| 1794 | 28 | 119 | push @results, $row; | |||
| 1795 | } | |||||
| 1796 | ||||||
| 1797 | # Return all rows as an array in list context | |||||
| 1798 | 12 | 87 | return @results; | |||
| 1799 | } | |||||
| 1800 | ||||||
| 1801 - 1807 | =head2 updated Returns the Unix timestamp of the last database update (mtime for file-based backends, or the time of the most recent C<new()> call for DSN-based connections). =cut | |||||
| 1808 | ||||||
| 1809 | sub updated { | |||||
| 1810 | 9 | 455 | my $self = shift; | |||
| 1811 | ||||||
| 1812 | 9 | 18 | return $self->{'_updated'}; | |||
| 1813 | } | |||||
| 1814 | ||||||
| 1815 - 1836 | =head2 columns Returns an array reference of column names for the current table. my $cols = $db->columns(); # e.g. ['entry', 'name', 'score', 'status'] The column list is determined by the backend: =over 4 =item * B<Slurp mode> - sorted keys of the first row in memory. =item * B<SQLite / other DBI> - a zero-row C<SELECT *> exposes the driver's C<NAME> attribute. =item * B<BerkeleyDB> - always returns C<['entry', 'value']>. =back The result is cached inside the object after the first call. =cut | |||||
| 1837 | ||||||
| 1838 | sub columns { | |||||
| 1839 | 31 | 3947 | my $self = shift; | |||
| 1840 | ||||||
| 1841 | 31 | 68 | return $self->{'_columns'} if $self->{'_columns'}; | |||
| 1842 | ||||||
| 1843 | 26 | 54 | my $table = $self->_open_table({}); | |||
| 1844 | ||||||
| 1845 | 26 | 61 | my @cols; | |||
| 1846 | ||||||
| 1847 | 26 | 40 | if($self->{'berkeley'}) { | |||
| 1848 | 1 | 2 | return $self->{'_columns'} = ['entry', 'value']; | |||
| 1849 | } | |||||
| 1850 | ||||||
| 1851 | 25 | 40 | if(my $data = $self->{'data'}) { | |||
| 1852 | 20 | 34 | if(ref($data) eq 'HASH') { | |||
| 1853 | 15 15 | 13 18 | my ($first) = values %{$data}; | |||
| 1854 | 15 15 | 22 27 | @cols = sort keys %{$first} if $first; | |||
| 1855 | 5 | 10 | } elsif(ref($data) eq 'ARRAY' && @{$data}) { | |||
| 1856 | 5 5 | 4 12 | @cols = sort keys %{$data->[0]}; | |||
| 1857 | } | |||||
| 1858 | } else { | |||||
| 1859 | 5 | 27 | my $sth = $self->{$table}->prepare_cached("SELECT * FROM $table WHERE 1=0"); | |||
| 1860 | 5 | 3392 | $sth->execute(); | |||
| 1861 | 5 5 | 5789 26 | @cols = @{$sth->{NAME}}; | |||
| 1862 | 5 | 33 | $sth->finish(); | |||
| 1863 | } | |||||
| 1864 | ||||||
| 1865 | 25 | 64 | return $self->{'_columns'} = \@cols; | |||
| 1866 | } | |||||
| 1867 | ||||||
| 1868 - 1911 | =head2 schema
Returns a hash reference describing the schema of the current table.
Each key is a column name; each value is a hash reference with these keys:
=over 4
=item * C<type> - data type string (e.g. C<TEXT>, C<INTEGER>, C<REAL>)
=item * C<nullable> - C<1> if the column may be NULL, C<0> if NOT NULL
=item * C<default> - default value string, or C<undef>
=item * C<pk> - C<1> if this column is (part of) the primary key, C<0> otherwise
=back
my $schema = $db->schema();
for my $col (sort keys %{$schema}) {
my $info = $schema->{$col};
printf "%s %s %s\n",
$col,
$info->{type},
$info->{nullable} ? 'NULL' : 'NOT NULL';
}
The schema is determined by the backend:
=over 4
=item * B<SQLite> - C<PRAGMA table_info(table)>
=item * B<Other DBI drivers> - C<< $dbh->column_info(...) >>
=item * B<Slurp mode> - inferred from the first row (all columns typed as C<TEXT>)
=item * B<BerkeleyDB> - always returns C<entry> (pk) and C<value>
=back
The result is cached inside the object after the first call.
=cut | |||||
| 1912 | ||||||
| 1913 | sub schema { | |||||
| 1914 | 26 | 6350 | my $self = shift; | |||
| 1915 | ||||||
| 1916 | 26 | 49 | return $self->{'_schema'} if $self->{'_schema'}; | |||
| 1917 | ||||||
| 1918 | 21 | 41 | my $table = $self->_open_table({}); | |||
| 1919 | 21 | 23 | my %schema; | |||
| 1920 | ||||||
| 1921 | 21 | 35 | if($self->{'berkeley'}) { | |||
| 1922 | 1 | 5 | return $self->{'_schema'} = { | |||
| 1923 | entry => { type => 'TEXT', nullable => 0, default => undef, pk => 1 }, | |||||
| 1924 | value => { type => 'TEXT', nullable => 1, default => undef, pk => 0 }, | |||||
| 1925 | }; | |||||
| 1926 | } | |||||
| 1927 | ||||||
| 1928 | 20 | 32 | if(my $data = $self->{'data'}) { | |||
| 1929 | 15 | 16 | my $first; | |||
| 1930 | 15 | 31 | if(ref($data) eq 'HASH') { | |||
| 1931 | 10 10 | 9 37 | ($first) = values %{$data}; | |||
| 1932 | 5 | 10 | } elsif(ref($data) eq 'ARRAY' && @{$data}) { | |||
| 1933 | 5 | 6 | $first = $data->[0]; | |||
| 1934 | } | |||||
| 1935 | 15 | 24 | if($first) { | |||
| 1936 | 15 | 19 | my $id = $self->{'id'}; | |||
| 1937 | 15 15 | 12 21 | for my $col (keys %{$first}) { | |||
| 1938 | 30 | 82 | $schema{$col} = { | |||
| 1939 | type => 'TEXT', | |||||
| 1940 | nullable => ($col eq $id ? 0 : 1), | |||||
| 1941 | default => undef, | |||||
| 1942 | pk => ($col eq $id ? 1 : 0), | |||||
| 1943 | }; | |||||
| 1944 | } | |||||
| 1945 | } | |||||
| 1946 | } else { | |||||
| 1947 | 5 | 46 | my $driver = $self->{$table}->{'Driver'}{'Name'} // ''; | |||
| 1948 | 5 | 19 | if($driver eq 'SQLite') { | |||
| 1949 | 4 | 16 | my $sth = $self->{$table}->prepare_cached("PRAGMA table_info($table)"); | |||
| 1950 | 4 | 214 | $sth->execute(); | |||
| 1951 | 4 | 53 | while(my $row = $sth->fetchrow_hashref()) { | |||
| 1952 | $schema{$row->{'name'}} = { | |||||
| 1953 | type => $row->{'type'}, | |||||
| 1954 | nullable => !$row->{'notnull'}, | |||||
| 1955 | default => $row->{'dflt_value'}, | |||||
| 1956 | 11 | 102 | pk => $row->{'pk'}, | |||
| 1957 | }; | |||||
| 1958 | } | |||||
| 1959 | 4 | 12 | $sth->finish(); | |||
| 1960 | } else { | |||||
| 1961 | 1 | 7 | my $sth = $self->{$table}->column_info(undef, undef, $table, '%'); | |||
| 1962 | 1 | 2 | if($sth) { | |||
| 1963 | 0 | 0 | while(my $row = $sth->fetchrow_hashref()) { | |||
| 1964 | $schema{$row->{'COLUMN_NAME'}} = { | |||||
| 1965 | type => $row->{'TYPE_NAME'}, | |||||
| 1966 | nullable => $row->{'NULLABLE'}, | |||||
| 1967 | 0 | 0 | default => $row->{'COLUMN_DEF'}, | |||
| 1968 | pk => 0, | |||||
| 1969 | }; | |||||
| 1970 | } | |||||
| 1971 | 0 | 0 | $sth->finish(); | |||
| 1972 | } | |||||
| 1973 | } | |||||
| 1974 | } | |||||
| 1975 | ||||||
| 1976 | 20 | 59 | return $self->{'_schema'} = \%schema; | |||
| 1977 | } | |||||
| 1978 | ||||||
| 1979 - 2000 | =head2 query
Returns a new L<Database::Abstraction::Query> builder object bound to this
database instance, for fluent method-chaining queries.
# All active rows with high scores, newest first, max 10
my $rows = $db->query
->where(status => 'active')
->where(score => { '>' => 80 })
->order_by('score DESC')
->limit(10)
->all();
# Single row
my $row = $db->query->where(name => 'Alice')->first();
# Just a count
my $n = $db->query->where(status => 'active')->count();
See L<Database::Abstraction::Query> for the full API.
=cut | |||||
| 2001 | ||||||
| 2002 | sub query | |||||
| 2003 | { | |||||
| 2004 | 132 | 35001 | my $self = shift; | |||
| 2005 | 132 | 1761 | require Database::Abstraction::Query; | |||
| 2006 | 132 | 239 | return Database::Abstraction::Query->new(_db => $self); | |||
| 2007 | } | |||||
| 2008 | ||||||
| 2009 - 2053 | =head2 AUTOLOAD - column shortcut
Calling an unknown method whose name matches a column name performs a column
lookup. The method name is the column you want; the arguments are criteria.
# Scalar context: return the first match
my $name = $db->name(entry => 'key1');
# List context: return all matching values
my @names = $db->name();
# Shortcut when the table has an 'entry' key column
my $name = $db->name('key1'); # same as name(entry => 'key1')
# Unique/distinct values
my @statuses = $db->status(distinct => 1);
B<In list context> the full column is returned (all rows), ordered by the
column value. B<In scalar context> only the first match is returned
(C<LIMIT 1>).
Results come from the slurp cache when available.
Throws an error if the column does not exist (slurp mode) or if AUTOLOAD
has been disabled with C<< auto_load => 0 >>.
=head3 PSEUDOCODE
1. Extract column name from $AUTOLOAD; guard on DESTROY.
2. Croak if auto_load => 0.
3. Validate $column against /^[a-zA-Z_][a-zA-Z0-9_]*$/.
4. If data is slurped:
a. List context, no params -> map column over all rows (exists guard).
b. entry-only param -> direct hash lookup (exists guard).
c. No params, scalar -> first value in hash.
d. no_entry set -> scan array for matching key/value pair.
e. Other params -> scan keyed hash for matching column.
5. If not slurped, build SQL:
- List: SELECT column FROM table [WHERE ...] ORDER BY column
- Scalar: SELECT DISTINCT column FROM table [WHERE ...] LIMIT 1
6. Check cache; return on HIT.
7. prepare_cached + execute; fetch result.
8. Store in cache; fixate; return.
=cut | |||||
| 2054 | ||||||
| 2055 | sub AUTOLOAD { | |||||
| 2056 | 117 | 17801 | our $AUTOLOAD; | |||
| 2057 | 117 | 388 | my ($column) = $AUTOLOAD =~ /::(\w+)\z/; | |||
| 2058 | ||||||
| 2059 | 117 | 174 | return if($column eq 'DESTROY'); | |||
| 2060 | 117 | 167 | return if($column =~ /\A_/); # never treat private method names as column lookups | |||
| 2061 | ||||||
| 2062 | 114 | 191 | my $self = shift or return; | |||
| 2063 | ||||||
| 2064 | 114 | 139 | Carp::croak(__PACKAGE__, ": Unknown column $column") if(!ref($self)); | |||
| 2065 | ||||||
| 2066 | # Allow the AUTOLOAD feature to be disabled | |||||
| 2067 | 114 | 277 | Carp::croak(__PACKAGE__, ": AUTOLOAD disabled (auto_load => 0)") if(exists($self->{'auto_load'}) && !$self->{'auto_load'}); | |||
| 2068 | ||||||
| 2069 | # Validate column name - only allow safe column name | |||||
| 2070 | 109 | 351 | Carp::croak(__PACKAGE__, ": Invalid column name: $column") unless $column =~ $SAFE_IDENTIFIER; | |||
| 2071 | ||||||
| 2072 | 109 | 164 | my $table = $self->_open_table(); | |||
| 2073 | ||||||
| 2074 | 108 | 94 | my %params; | |||
| 2075 | 108 | 219 | if(ref($_[0]) eq 'HASH') { | |||
| 2076 | 2 2 | 2 4 | %params = %{$_[0]}; | |||
| 2077 | } elsif((scalar(@_) % 2) == 0) { | |||||
| 2078 | 83 | 109 | %params = @_; | |||
| 2079 | } elsif(scalar(@_) == 1) { | |||||
| 2080 | # Don't error on key-value databases, since there's no idea of columns | |||||
| 2081 | 23 | 55 | if($self->{'no_entry'} && !$self->{'berkeley'}) { | |||
| 2082 | 0 | 0 | Carp::croak(ref($self), "::($_[0]): ", $self->{'id'}, ' is not a column'); | |||
| 2083 | } | |||||
| 2084 | 23 | 35 | $params{'entry'} = shift; | |||
| 2085 | } | |||||
| 2086 | ||||||
| 2087 | 108 | 184 | if($self->{'berkeley'}) { | |||
| 2088 | 0 | 0 | if(my $id = $self->{'id'}) { | |||
| 2089 | 0 | 0 | return $self->{'berkeley'}->{$params{$id}}; | |||
| 2090 | } | |||||
| 2091 | 0 | 0 | return $self->{'berkeley'}->{$params{'entry'}}; | |||
| 2092 | } | |||||
| 2093 | ||||||
| 2094 | 108 | 157 | croak('Where did the data come from?') if(!defined($self->{'type'})); | |||
| 2095 | 108 | 68 | my $query; | |||
| 2096 | 108 | 105 | my $done_where = 0; | |||
| 2097 | 108 | 228 | my $distinct = delete($params{'distinct'}) || delete($params{'unique'}); | |||
| 2098 | ||||||
| 2099 | 108 | 163 | if(wantarray && !$distinct) { | |||
| 2100 | 24 | 74 | if(((scalar keys %params) == 0) && (my $data = $self->{'data'})) { | |||
| 2101 | # Return all column values from the in-memory hash. | |||||
| 2102 | # Use exists() because fixate() locks inner row hashes â | |||||
| 2103 | # accessing a disallowed key would throw without the guard. | |||||
| 2104 | # Handle both HASH (keyed data) and ARRAY (no_entry CSV slurp). | |||||
| 2105 | 20 2 18 | 30 4 27 | my @_rows = ref($data) eq 'ARRAY' ? @{$data} : values %{$data}; | |||
| 2106 | 20 82 | 27 126 | return map { exists($_->{$column}) ? $_->{$column} : undef } @_rows; | |||
| 2107 | } | |||||
| 2108 | 4 | 7 | my $id = $self->{'id'}; | |||
| 2109 | 4 | 10 | if(($self->{'type'} eq 'CSV') && !$self->{'no_entry'}) { | |||
| 2110 | 2 | 3 | $query = "SELECT $column FROM $table WHERE $id IS NOT NULL AND $id NOT LIKE '#%'"; | |||
| 2111 | 2 | 5 | $done_where = 1; | |||
| 2112 | } else { | |||||
| 2113 | 2 | 3 | $query = "SELECT $column FROM $table"; | |||
| 2114 | } | |||||
| 2115 | } else { | |||||
| 2116 | 84 | 159 | if(my $data = $self->{'data'}) { | |||
| 2117 | # The data has been read in using Text::xSV::Slurp, | |||||
| 2118 | # so no need to do any SQL | |||||
| 2119 | 63 | 105 | $self->_debug('AUTOLOAD using slurped data'); | |||
| 2120 | 63 | 1627 | if($self->{'no_entry'}) { | |||
| 2121 | 4 | 5 | $self->_debug('no_entry is set'); | |||
| 2122 | 4 | 52 | my ($key, $value) = %params; | |||
| 2123 | 4 | 7 | if(defined($key)) { | |||
| 2124 | 4 | 8 | $self->_debug("key = $key, value = $value, column = $column"); | |||
| 2125 | 4 4 | 72 5 | foreach my $row(@{$data}) { | |||
| 2126 | # exists() guards: fixate() locks row hashes recursively | |||||
| 2127 | 6 | 21 | next unless exists($row->{$key}) && defined($row->{$key}) && $row->{$key} eq $value; | |||
| 2128 | 3 | 6 | my $rc = exists($row->{$column}) ? $row->{$column} : undef; | |||
| 2129 | 3 | 13 | $self->_trace(__LINE__, ": AUTOLOAD $key: return ", defined($rc) ? "'$rc'" : 'undef', ' from slurped data'); | |||
| 2130 | 3 | 43 | return $rc; | |||
| 2131 | } | |||||
| 2132 | 1 | 1 | $self->_debug('not found in slurped data'); | |||
| 2133 | } | |||||
| 2134 | } elsif(((scalar keys %params) == 1) && defined(my $key = $params{'entry'})) { | |||||
| 2135 | # Look up a single entry by its key. | |||||
| 2136 | # Use exists() before accessing â fixate() locks the outer hash and | |||||
| 2137 | # dereferencing a missing key on a locked hash throws an exception. | |||||
| 2138 | 46 | 56 | my $rc; | |||
| 2139 | 46 | 121 | if(exists($data->{$key}) && defined(my $hash = $data->{$key})) { | |||
| 2140 | 36 | 84 | if(!exists($hash->{$column})) { | |||
| 2141 | 4 | 40 | Carp::croak(__PACKAGE__, ": There is no column $column in $table"); | |||
| 2142 | } | |||||
| 2143 | 32 | 37 | $rc = $hash->{$column}; | |||
| 2144 | } | |||||
| 2145 | 42 | 60 | if(defined($rc)) { | |||
| 2146 | 29 | 70 | $self->_trace(__LINE__, ": AUTOLOAD $key: return '$rc' from slurped data"); | |||
| 2147 | } else { | |||||
| 2148 | 13 | 26 | $self->_trace(__LINE__, ": AUTOLOAD $key: return undef from slurped data"); | |||
| 2149 | } | |||||
| 2150 | 42 | 854 | return $rc | |||
| 2151 | } elsif((scalar keys %params) == 0) { | |||||
| 2152 | 9 | 11 | if(wantarray) { | |||
| 2153 | 9 | 20 | if($distinct) { | |||
| 2154 | # Single pass instead of three (mapâgrepâmap): avoids three | |||||
| 2155 | # intermediate lists of size N on the stack. | |||||
| 2156 | 9 | 8 | my %h; | |||
| 2157 | 9 9 | 11 14 | for my $r (values %{$data}) { | |||
| 2158 | 35 | 47 | my $v = exists($r->{$column}) ? $r->{$column} : undef; | |||
| 2159 | 35 | 54 | $h{$v} = 1 if defined $v; | |||
| 2160 | } | |||||
| 2161 | 9 | 28 | return keys %h; | |||
| 2162 | } | |||||
| 2163 | # DEAD CODE: unreachable because the outer `if(wantarray && !$distinct)` | |||||
| 2164 | # handles the wantarray+!distinct case. In this else branch, wantarray | |||||
| 2165 | # implies $distinct (which returns above), so this line is never executed. | |||||
| 2166 | # return map { exists($_->{$column}) ? $_->{$column} : undef } values %{$data} | |||||
| 2167 | } | |||||
| 2168 | # Scalar: return the first value found without building a full list | |||||
| 2169 | 0 0 | 0 0 | foreach my $v (values %{$data}) { | |||
| 2170 | 0 | 0 | return exists($v->{$column}) ? $v->{$column} : undef; | |||
| 2171 | } | |||||
| 2172 | } else { | |||||
| 2173 | # Keyed data but filtering on a non-key column | |||||
| 2174 | 4 | 6 | my ($key, $value) = %params; | |||
| 2175 | 4 4 | 6 6 | foreach my $row (values %{$data}) { | |||
| 2176 | 10 | 34 | next unless exists($row->{$key}) && defined($row->{$key}) && $row->{$key} eq $value; | |||
| 2177 | 4 | 8 | next unless exists($row->{$column}); | |||
| 2178 | 4 | 8 | if(my $rc = $row->{$column}) { | |||
| 2179 | 4 | 11 | $self->_trace(__LINE__, ": AUTOLOAD $key: return '$rc' from slurped data"); | |||
| 2180 | 4 | 101 | return $rc | |||
| 2181 | } | |||||
| 2182 | } | |||||
| 2183 | } | |||||
| 2184 | return | |||||
| 2185 | 1 | 14 | } | |||
| 2186 | # Data has not been slurped in | |||||
| 2187 | 21 | 44 | my $id = $self->{'id'}; | |||
| 2188 | 21 | 53 | if(($self->{'type'} eq 'CSV') && !$self->{'no_entry'}) { | |||
| 2189 | 11 | 14 | $query = "SELECT DISTINCT $column FROM $table WHERE $id IS NOT NULL AND $id NOT LIKE '#%'"; | |||
| 2190 | 11 | 10 | $done_where = 1; | |||
| 2191 | } else { | |||||
| 2192 | 10 | 19 | $query = "SELECT DISTINCT $column FROM $table"; | |||
| 2193 | } | |||||
| 2194 | } | |||||
| 2195 | 25 | 20 | my @args; | |||
| 2196 | # Avoid `each` â it carries hidden iterator state across calls | |||||
| 2197 | 25 | 46 | for my $k (sort keys %params) { | |||
| 2198 | # Guard against SQL injection via column names â same rule as _build_where_conditions | |||||
| 2199 | 20 | 155 | Carp::croak(__PACKAGE__, ": unsafe column name '$k'") | |||
| 2200 | unless $k =~ $SAFE_QUALIFIED; | |||||
| 2201 | 16 | 21 | my $value = $params{$k}; | |||
| 2202 | 16 | 49 | $self->_debug(__PACKAGE__, ": AUTOLOAD adding key/value pair $k=>", defined($value) ? $value : 'NULL'); | |||
| 2203 | 16 | 603 | if(defined($value)) { | |||
| 2204 | 14 | 32 | $query .= $done_where ? " AND $k = ?" : " WHERE $k = ?"; | |||
| 2205 | 14 | 14 | $done_where = 1; | |||
| 2206 | 14 | 25 | push @args, $value; | |||
| 2207 | } else { | |||||
| 2208 | 2 | 5 | $query .= $done_where ? " AND $k IS NULL" : " WHERE $k IS NULL"; | |||
| 2209 | 2 | 3 | $done_where = 1; | |||
| 2210 | } | |||||
| 2211 | } | |||||
| 2212 | 21 | 36 | if(wantarray) { | |||
| 2213 | 5 | 6 | $query .= " ORDER BY $column"; | |||
| 2214 | } else { | |||||
| 2215 | 16 | 19 | $query .= ' LIMIT 1'; | |||
| 2216 | } | |||||
| 2217 | 21 | 48 | if(scalar(@args) && $args[0]) { | |||
| 2218 | 14 | 36 | $self->_debug("AUTOLOAD $query: ", join(', ', @args)); | |||
| 2219 | } else { | |||||
| 2220 | 7 | 13 | $self->_debug("AUTOLOAD $query"); | |||
| 2221 | } | |||||
| 2222 | 21 | 627 | my $cache; | |||
| 2223 | 21 | 31 | my $key = ref($self) . '::'; | |||
| 2224 | 21 | 28 | if($cache = $self->{cache}) { | |||
| 2225 | 0 | 0 | if(wantarray) { | |||
| 2226 | 0 | 0 | $key .= 'array '; | |||
| 2227 | } | |||||
| 2228 | 0 | 0 | if(defined($args[0])) { | |||
| 2229 | 0 | 0 | $key .= "fetchrow $query " . join(', ', @args); | |||
| 2230 | } else { | |||||
| 2231 | 0 | 0 | $key .= "fetchrow $query"; | |||
| 2232 | } | |||||
| 2233 | 0 | 0 | if(my $rc = $cache->get($key)) { | |||
| 2234 | 0 | 0 | $self->_debug('cache HIT'); | |||
| 2235 | 0 0 | 0 0 | return wantarray ? @{$rc} : $rc; # We stored a ref to the array | |||
| 2236 | } | |||||
| 2237 | 0 | 0 | $self->_debug('cache MISS'); | |||
| 2238 | } else { | |||||
| 2239 | 21 | 29 | $self->_debug('cache not used'); | |||
| 2240 | } | |||||
| 2241 | 21 | 635 | my $sth = $self->{$table}->prepare_cached($query) || croak($query); | |||
| 2242 | 21 | 32048 | $sth->execute(@args) || croak($query); | |||
| 2243 | ||||||
| 2244 | 21 | 28461 | if(wantarray) { | |||
| 2245 | # fetchall_arrayref([0]) asks DBI to project column 0 server-side, so each | |||||
| 2246 | # returned row is [$col0] instead of the full row â less memory, same result. | |||||
| 2247 | 5 17 5 | 6 294 36 | my @rc = map { $_->[0] } @{$sth->fetchall_arrayref([0])}; | |||
| 2248 | 5 | 12 | if($cache) { | |||
| 2249 | 0 | 0 | $cache->set($key, \@rc, $self->{'cache_duration'}); # Store a ref to the array | |||
| 2250 | } | |||||
| 2251 | 5 | 38 | Database::Abstraction::_fixate($self, \@rc) if(scalar(@rc) && !$self->{'no_fixate'}); | |||
| 2252 | 5 | 317 | return @rc; | |||
| 2253 | } | |||||
| 2254 | 16 | 95 | my $rc = $sth->fetchrow_array(); # Return the first match only | |||
| 2255 | 16 | 270 | $sth->finish(); | |||
| 2256 | 16 | 64 | if($cache) { | |||
| 2257 | # Store the value, then return it â cache->set() return value is unreliable | |||||
| 2258 | 0 | 0 | $cache->set($key, $rc, $self->{'cache_duration'}); | |||
| 2259 | } | |||||
| 2260 | 16 | 56 | return $rc; | |||
| 2261 | } | |||||
| 2262 | ||||||
| 2263 | sub DESTROY | |||||
| 2264 | { | |||||
| 2265 | 412 | 124772 | if(defined($^V) && ($^V ge 'v5.14.0')) { | |||
| 2266 | 412 | 640 | return if ${^GLOBAL_PHASE} eq 'DESTRUCT'; # >= 5.14.0 only | |||
| 2267 | } | |||||
| 2268 | ||||||
| 2269 | 412 | 603 | my $self = shift; | |||
| 2270 | ||||||
| 2271 | # Clean up temporary files â deleting File::Temp objects triggers auto-unlink/rmdir | |||||
| 2272 | # If that doesn't happen for some reason, explicitly unlink | |||||
| 2273 | 412 | 509 | if(defined $self->{'_temp_fh'}) { | |||
| 2274 | 12 | 11 | my $temp_fh = $self->{'_temp_fh'}; | |||
| 2275 | 12 12 | 11 18 | my $temp_path = eval { $temp_fh->filename() }; | |||
| 2276 | 12 | 40 | delete $self->{'_temp_fh'}; | |||
| 2277 | # Fallback explicit unlink if File::Temp didn't clean up | |||||
| 2278 | 12 | 69 | unlink($temp_path) if defined($temp_path) && -f $temp_path; | |||
| 2279 | } | |||||
| 2280 | 412 | 1712 | delete $self->{'_remote_tmpdir'}; | |||
| 2281 | ||||||
| 2282 | # Clean up database handles | |||||
| 2283 | 412 | 709 | my $table_name = $self->{'table'} || ref($self); | |||
| 2284 | 412 | 1012 | $table_name =~ s/\A.*:://; | |||
| 2285 | ||||||
| 2286 | 412 | 577 | if(my $dbh = delete $self->{$table_name}) { | |||
| 2287 | 236 | 2544 | $dbh->disconnect() if $dbh->can('disconnect'); | |||
| 2288 | 236 | 3624 | $dbh->finish() if $dbh->can('finish'); | |||
| 2289 | } | |||||
| 2290 | ||||||
| 2291 | # Clean up Berkeley DB | |||||
| 2292 | 412 | 517 | if($self->{'berkeley'}) { | |||
| 2293 | 20 | 20 | eval { | |||
| 2294 | 20 20 | 14 22 | untie %{$self->{'berkeley'}}; | |||
| 2295 | }; | |||||
| 2296 | 20 | 24 | delete $self->{'berkeley'}; | |||
| 2297 | } | |||||
| 2298 | ||||||
| 2299 | # Clear all other attributes to break potential circular references | |||||
| 2300 | 412 | 753 | foreach my $key (keys %$self) { | |||
| 2301 | 4294 | 7880 | delete $self->{$key}; | |||
| 2302 | } | |||||
| 2303 | } | |||||
| 2304 | ||||||
| 2305 | # Build the JOIN clause(s) from a single join hashref or arrayref of hashrefs. | |||||
| 2306 | # Each spec needs keys: table (required), on (required), type (default INNER). | |||||
| 2307 | sub _build_joins | |||||
| 2308 | { | |||||
| 2309 | 59 | 4157 | my ($self, $join_spec) = @_; | |||
| 2310 | ||||||
| 2311 | 59 8 | 121 11 | my @specs = ref($join_spec) eq 'ARRAY' ? @{$join_spec} : ($join_spec); | |||
| 2312 | 59 | 46 | my @clauses; | |||
| 2313 | ||||||
| 2314 | 59 | 63 | for my $j (@specs) { | |||
| 2315 | 60 | 126 | my $type = uc($j->{'type'} // 'INNER'); | |||
| 2316 | 60 | 106 | my $jtable = $j->{'table'} or Carp::croak('join: missing "table"'); | |||
| 2317 | 56 | 284 | Carp::croak("join: unsafe table name '$jtable'") | |||
| 2318 | unless $jtable =~ $SAFE_QUALIFIED; | |||||
| 2319 | 46 | 87 | my $on = $j->{'on'} or Carp::croak('join: missing "on" condition'); | |||
| 2320 | 42 | 136 | Carp::croak("Invalid JOIN type: $type") unless $VALID_JOIN_TYPES{$type}; | |||
| 2321 | 35 | 70 | push @clauses, "$type JOIN $jtable ON ($on)"; | |||
| 2322 | } | |||||
| 2323 | ||||||
| 2324 | 34 | 67 | return join(' ', @clauses); | |||
| 2325 | } | |||||
| 2326 | ||||||
| 2327 | # Return true when $params contains operator hashrefs, -or, or -and groupings | |||||
| 2328 | # that the simple slurp fast-path cannot handle. | |||||
| 2329 | sub _has_complex_criteria | |||||
| 2330 | { | |||||
| 2331 | 171 | 218 | my ($self, $params) = @_; | |||
| 2332 | 171 | 183 | return 0 unless defined $params; | |||
| 2333 | 169 | 341 | return 1 if exists $params->{'-or'} || exists $params->{'-and'}; | |||
| 2334 | 164 164 | 118 192 | for my $v (values %{$params}) { | |||
| 2335 | 99 | 147 | return 1 if ref($v); | |||
| 2336 | } | |||||
| 2337 | 160 | 246 | return 0; | |||
| 2338 | } | |||||
| 2339 | ||||||
| 2340 | # Build the WHERE clause body (everything after "WHERE") from a criteria hash. | |||||
| 2341 | # Handles -or / -and groupings then delegates per-column work to _build_where_conditions. | |||||
| 2342 | # Returns ($sql_fragment, \@bind_values). | |||||
| 2343 | # Wrapper around Data::Reuse::fixate() that suppresses the spurious | |||||
| 2344 | # "Use of uninitialized value in hash slice" warning. Data::Alias's XS | |||||
| 2345 | # hash-aliasing code does not fully initialise key SVs on older Perl | |||||
| 2346 | # versions when the source hash contains undef values (NULL columns). | |||||
| 2347 | # Data::Reuse still fixates correctly; the warning is a false positive. | |||||
| 2348 | # $struct must be the hashref or arrayref to fixate. | |||||
| 2349 | sub _fixate :Private | |||||
| 2350 | { | |||||
| 2351 | my (undef, $struct) = @_; | |||||
| 2352 | return unless defined $struct; | |||||
| 2353 | # Clear stale addressâcanonical mappings from prior fixate calls before | |||||
| 2354 | # fixating $struct. Without this, freed hashref addresses from a previous | |||||
| 2355 | # object's slurp or DBI result can be reused by the allocator for new | |||||
| 2356 | # hashrefs; fixate() would then find the stale entry and alias the new | |||||
| 2357 | # hashref to the wrong canonical, silently substituting one row's data for | |||||
| 2358 | # another. This is the same stale-address hazard that affects DBI paths | |||||
| 2359 | # (see selectall_arrayref / selectall_array) but also affects the slurp | |||||
| 2360 | # fixate when earlier objects go out of scope before a new slurp runs. | |||||
| 2361 | Data::Reuse::forget(); | |||||
| 2362 | local $SIG{__WARN__} = sub { | |||||
| 2363 | # Two index() calls replace the former /.*\b/ â no backtracking at all. | |||||
| 2364 | # The prefix check is constant-time; the suffix scan is O(n) but stops | |||||
| 2365 | # at the first match rather than first matching greedily then retreating. | |||||
| 2366 | warn @_ unless | |||||
| 2367 | index($_[0], 'Use of uninitialized value') == 0 | |||||
| 2368 | && index($_[0], 'in hash slice') >= 0; | |||||
| 2369 | }; | |||||
| 2370 | &Data::Reuse::fixate($struct); | |||||
| 2371 | 35 35 35 | 118707 35 332 | } | |||
| 2372 | ||||||
| 2373 | sub _build_where | |||||
| 2374 | { | |||||
| 2375 | 305 | 3835 | my ($self, $params) = @_; | |||
| 2376 | ||||||
| 2377 | 305 | 350 | $params //= {}; | |||
| 2378 | 305 | 299 | my @clauses; | |||
| 2379 | my @args; | |||||
| 2380 | ||||||
| 2381 | # Avoid an O(K) hash copy in the common case where neither -or nor -and is | |||||
| 2382 | # present. Only copy when we actually need to delete grouping keys, so the | |||||
| 2383 | # plain-criteria path (the vast majority of queries) passes $params through | |||||
| 2384 | # directly to _build_where_conditions without any allocation. | |||||
| 2385 | 305 | 374 | my $or_list = $params->{'-or'}; | |||
| 2386 | 293 | 225 | my $and_list = $params->{'-and'}; | |||
| 2387 | 305 | 218 | my $plain; | |||
| 2388 | 293 | 448 | if(defined($or_list) || defined($and_list)) { | |||
| 2389 | 22 22 | 16 37 | my %p = %{$params}; | |||
| 2390 | 22 | 34 | delete @p{qw(-or -and)}; | |||
| 2391 | 22 | 20 | $plain = \%p; | |||
| 2392 | } else { | |||||
| 2393 | 271 | 191 | $plain = $params; | |||
| 2394 | } | |||||
| 2395 | ||||||
| 2396 | 293 | 266 | if($or_list) { | |||
| 2397 | 16 | 13 | my (@sub_clauses, @sub_args); | |||
| 2398 | 16 16 | 11 20 | for my $cond (@{$or_list}) { | |||
| 2399 | 30 | 31 | my ($s, $a) = $self->_build_where_conditions($cond); | |||
| 2400 | 30 | 35 | if($s) { | |||
| 2401 | 30 | 30 | push @sub_clauses, "($s)"; | |||
| 2402 | 30 30 | 20 36 | push @sub_args, @{$a}; | |||
| 2403 | } | |||||
| 2404 | } | |||||
| 2405 | 16 | 21 | if(@sub_clauses) { | |||
| 2406 | 15 | 22 | push @clauses, '(' . join(' OR ', @sub_clauses) . ')'; | |||
| 2407 | 15 | 19 | push @args, @sub_args; | |||
| 2408 | } | |||||
| 2409 | } | |||||
| 2410 | 293 | 256 | if($and_list) { | |||
| 2411 | 6 | 6 | my (@sub_clauses, @sub_args); | |||
| 2412 | 6 6 | 6 6 | for my $cond (@{$and_list}) { | |||
| 2413 | 11 | 14 | my ($s, $a) = $self->_build_where_conditions($cond); | |||
| 2414 | 11 | 16 | if($s) { | |||
| 2415 | 11 | 11 | push @sub_clauses, "($s)"; | |||
| 2416 | 11 11 | 9 13 | push @sub_args, @{$a}; | |||
| 2417 | } | |||||
| 2418 | } | |||||
| 2419 | 6 | 8 | if(@sub_clauses) { | |||
| 2420 | 6 | 11 | push @clauses, '(' . join(' AND ', @sub_clauses) . ')'; | |||
| 2421 | 6 | 7 | push @args, @sub_args; | |||
| 2422 | } | |||||
| 2423 | } | |||||
| 2424 | ||||||
| 2425 | 293 | 397 | my ($more, $margs) = $self->_build_where_conditions($plain); | |||
| 2426 | 276 | 309 | if($more) { | |||
| 2427 | 150 | 117 | push @clauses, $more; | |||
| 2428 | 150 150 | 118 154 | push @args, @{$margs}; | |||
| 2429 | } | |||||
| 2430 | ||||||
| 2431 | 276 | 447 | return (join(' AND ', @clauses), \@args); | |||
| 2432 | } | |||||
| 2433 | ||||||
| 2434 | # Build a WHERE-body fragment for a flat col => val hash. | |||||
| 2435 | # Values may be plain scalars (= / LIKE / IS NULL) or operator hashrefs | |||||
| 2436 | # ({ '>' => n }, { -in => [...] }, { -between => [lo,hi] }, etc.). | |||||
| 2437 | sub _build_where_conditions | |||||
| 2438 | { | |||||
| 2439 | 361 | 8052 | my ($self, $params) = @_; | |||
| 2440 | ||||||
| 2441 | 361 | 263 | my @clauses; | |||
| 2442 | my @args; | |||||
| 2443 | ||||||
| 2444 | 361 361 | 241 519 | for my $col (sort keys %{$params}) { | |||
| 2445 | 243 | 219 | my $val = $params->{$col}; | |||
| 2446 | ||||||
| 2447 | # Guard against SQL injection via column names; allow table.column notation for JOINs | |||||
| 2448 | 243 | 972 | Carp::croak("_build_where_conditions: unsafe column name '$col'") | |||
| 2449 | unless $col =~ $SAFE_QUALIFIED; | |||||
| 2450 | ||||||
| 2451 | 228 | 427 | if(ref($val) eq 'HASH') { | |||
| 2452 | 90 90 | 66 93 | for my $op (keys %{$val}) { # no sort â operator hashes typically have 1-2 keys; sort adds O(K log K) overhead | |||
| 2453 | 92 | 69 | my $operand = $val->{$op}; | |||
| 2454 | 92 | 289 | if($op eq '-in' || $op eq '-not_in') { | |||
| 2455 | 15 | 20 | my $sql_op = $op eq '-in' ? 'IN' : 'NOT IN'; | |||
| 2456 | 15 15 | 14 23 | my $ph = join(', ', ('?') x scalar(@{$operand})); | |||
| 2457 | 15 | 24 | push @clauses, "$col $sql_op ($ph)"; | |||
| 2458 | 15 15 | 12 30 | push @args, @{$operand}; | |||
| 2459 | } elsif($op eq '-between') { | |||||
| 2460 | 8 | 14 | push @clauses, "$col BETWEEN ? AND ?"; | |||
| 2461 | 8 | 16 | push @args, $operand->[0], $operand->[1]; | |||
| 2462 | } elsif($op eq '-like') { | |||||
| 2463 | 6 | 9 | push @clauses, "$col LIKE ?"; | |||
| 2464 | 6 | 12 | push @args, $operand; | |||
| 2465 | } elsif($op eq '-not_like') { | |||||
| 2466 | 6 | 11 | push @clauses, "$col NOT LIKE ?"; | |||
| 2467 | 6 | 11 | push @args, $operand; | |||
| 2468 | } elsif($op eq '!=') { | |||||
| 2469 | 8 | 11 | if(!defined($operand)) { | |||
| 2470 | 2 | 4 | push @clauses, "$col IS NOT NULL"; | |||
| 2471 | } else { | |||||
| 2472 | 6 | 10 | push @clauses, "$col != ?"; | |||
| 2473 | 6 | 10 | push @args, $operand; | |||
| 2474 | } | |||||
| 2475 | # [<>]=? matches >, <, >=, <= as a single character class â no alternation | |||||
| 2476 | # overhead, no backtracking, and self-documenting. | |||||
| 2477 | } elsif($op =~ /\A[<>]=?\z/) { | |||||
| 2478 | 46 | 57 | push @clauses, "$col $op ?"; | |||
| 2479 | 46 | 72 | push @args, $operand; | |||
| 2480 | } else { | |||||
| 2481 | 3 | 31 | Carp::croak("Unknown operator '$op' for column '$col'"); | |||
| 2482 | } | |||||
| 2483 | } | |||||
| 2484 | } elsif(ref($val)) { | |||||
| 2485 | 4 | 22 | Carp::croak("$col: expected scalar or operator hashref, got ", ref($val)); | |||
| 2486 | } elsif(!defined($val)) { | |||||
| 2487 | 9 | 27 | push @clauses, "$col IS NULL"; | |||
| 2488 | } elsif($val =~ /[%_]/) { | |||||
| 2489 | 9 | 14 | push @clauses, "$col LIKE ?"; | |||
| 2490 | 9 | 11 | push @args, $val; | |||
| 2491 | } else { | |||||
| 2492 | 116 | 122 | push @clauses, "$col = ?"; | |||
| 2493 | 116 | 165 | push @args, $val; | |||
| 2494 | } | |||||
| 2495 | } | |||||
| 2496 | ||||||
| 2497 | 339 | 601 | return (join(' AND ', @clauses), \@args); | |||
| 2498 | } | |||||
| 2499 | ||||||
| 2500 | # Test a single in-memory row value against a criteria value. | |||||
| 2501 | # $crit_val may be a plain scalar or an operator hashref. | |||||
| 2502 | # Returns true when the row value satisfies the criterion. | |||||
| 2503 | # Scan the entire BerkeleyDB tied hash, building rows as {entry=>$k, value=>$v}, | |||||
| 2504 | # and filter by $params criteria using _match_criterion. | |||||
| 2505 | # Croaks when JOINs or -or/-and groupings are requested (unsupported for key-value stores). | |||||
| 2506 | sub _scan_berkeley | |||||
| 2507 | { | |||||
| 2508 | 26 | 96 | my ($self, $params) = @_; | |||
| 2509 | 26 | 38 | $params //= {}; | |||
| 2510 | ||||||
| 2511 | # TODO: Data Flow Anomaly - Mutation side effect: delete mutates the caller's | |||||
| 2512 | # $params hashref in-place. All current callers (selectall_arrayref, | |||||
| 2513 | # selectall_array, count) do not reuse $params after this call, so it is safe; | |||||
| 2514 | # but a future caller that reuses $params would silently lose the 'join' key. | |||||
| 2515 | # Fix: use exists($params->{'join'}) to check; copy params before deleting. | |||||
| 2516 | 26 | 33 | if(delete $params->{'join'}) { | |||
| 2517 | 2 | 27 | Carp::croak(ref($self), ': BerkeleyDB does not support JOINs'); | |||
| 2518 | } | |||||
| 2519 | 24 11 24 | 14 27 32 | if(grep { $_ eq '-or' || $_ eq '-and' } keys %{$params}) { | |||
| 2520 | 3 | 35 | Carp::croak(ref($self), ': BerkeleyDB does not support -or/-and groupings'); | |||
| 2521 | } | |||||
| 2522 | ||||||
| 2523 | 21 | 17 | my $bdb = $self->{'berkeley'}; | |||
| 2524 | 21 21 | 17 21 | my @cols = keys %{$params}; | |||
| 2525 | 21 | 17 | my @rows; | |||
| 2526 | ||||||
| 2527 | 21 | 18 | if(@cols) { | |||
| 2528 | # Single-pass build+filter: avoids materialising the full N-row list | |||||
| 2529 | # before filtering. Peak memory is O(matching rows) instead of O(N). | |||||
| 2530 | 8 8 | 5 8 | for my $k (keys %{$bdb}) { | |||
| 2531 | 22 | 25 | my $row = { entry => $k, value => $bdb->{$k} }; | |||
| 2532 | 22 | 14 | my $match = 1; | |||
| 2533 | 22 | 16 | for my $col (@cols) { | |||
| 2534 | 22 | 46 | unless($self->_match_criterion($row->{$col}, $params->{$col})) { | |||
| 2535 | 13 | 7 | $match = 0; | |||
| 2536 | 13 | 10 | last; | |||
| 2537 | } | |||||
| 2538 | } | |||||
| 2539 | 22 | 26 | push @rows, $row if $match; | |||
| 2540 | } | |||||
| 2541 | } else { | |||||
| 2542 | 13 25 13 | 10 34 13 | @rows = map { { entry => $_, value => $bdb->{$_} } } keys %{$bdb}; | |||
| 2543 | } | |||||
| 2544 | ||||||
| 2545 | 21 | 52 | return \@rows; | |||
| 2546 | } | |||||
| 2547 | ||||||
| 2548 | # SQL LIKE match â case-insensitive, ReDoS-safe, no catastrophic backtracking. | |||||
| 2549 | # % matches any sequence of chars; _ matches exactly one char. | |||||
| 2550 | # | |||||
| 2551 | # Fast paths cover the four most common LIKE shapes using O(1) string ops: | |||||
| 2552 | # '%' â always true | |||||
| 2553 | # no wildcard â lc eq comparison | |||||
| 2554 | # '%suffix' â ends-with check via substr | |||||
| 2555 | # 'prefix%' â starts-with check via index | |||||
| 2556 | # '%mid%' â contains check via index (single inner literal, no _ wildcards) | |||||
| 2557 | # | |||||
| 2558 | # Full DP uses O(m) memory (two 1-D rolling arrays) instead of the O(m*n) 2-D | |||||
| 2559 | # table the naive approach allocates. Character access uses substr() instead of | |||||
| 2560 | # split(//) so no per-character scalar objects are created. | |||||
| 2561 | sub _like_match | |||||
| 2562 | { | |||||
| 2563 | 46 | 3418 | my ($str, $pattern) = @_; | |||
| 2564 | ||||||
| 2565 | # Fast path 1: bare '%' â matches any string regardless of content. | |||||
| 2566 | 46 | 55 | return 1 if $pattern eq '%'; | |||
| 2567 | ||||||
| 2568 | 43 | 37 | my $lc_str = lc($str); | |||
| 2569 | 43 | 33 | my $lc_pat = lc($pattern); | |||
| 2570 | 43 | 29 | my $pat_len = length($lc_pat); | |||
| 2571 | 43 | 35 | my $str_len = length($lc_str); | |||
| 2572 | ||||||
| 2573 | # Fast path 2: no wildcard characters â plain case-insensitive equality. | |||||
| 2574 | 43 | 66 | return ($lc_str eq $lc_pat) | |||
| 2575 | if index($lc_pat, '%') == -1 && index($lc_pat, '_') == -1; | |||||
| 2576 | ||||||
| 2577 | # Fast paths 3-5 apply only when the pattern has no '_' wildcards. | |||||
| 2578 | # (Patterns with '_' need per-character DP to enforce the single-char rule.) | |||||
| 2579 | 36 | 41 | if(index($lc_pat, '_') == -1) { | |||
| 2580 | 32 | 46 | my $first_pct = index($lc_pat, '%'); | |||
| 2581 | 32 | 31 | my $last_pct = rindex($lc_pat, '%'); | |||
| 2582 | ||||||
| 2583 | # Fast path 3: '%suffix' â exactly one '%', at the start. | |||||
| 2584 | 32 | 48 | if($first_pct == 0 && $last_pct == 0) { | |||
| 2585 | 8 | 6 | my $sfx = substr($lc_pat, 1); | |||
| 2586 | 8 | 7 | my $sfx_len = length($sfx); | |||
| 2587 | 8 | 22 | return $str_len >= $sfx_len | |||
| 2588 | && substr($lc_str, $str_len - $sfx_len) eq $sfx; | |||||
| 2589 | } | |||||
| 2590 | ||||||
| 2591 | # Fast path 4: 'prefix%' â exactly one '%', at the end. | |||||
| 2592 | 24 | 47 | if($last_pct == $pat_len - 1 && $first_pct == $pat_len - 1) { | |||
| 2593 | 12 | 15 | my $pfx = substr($lc_pat, 0, $pat_len - 1); | |||
| 2594 | 12 | 45 | return index($lc_str, $pfx) == 0; | |||
| 2595 | } | |||||
| 2596 | ||||||
| 2597 | # Fast path 5: '%literal%' â '%' at both ends, no inner '%'. | |||||
| 2598 | # pat_len >= 3 ensures there are two distinct '%' characters. | |||||
| 2599 | # Only return here when the middle segment is free of further wildcards; | |||||
| 2600 | # if it contains '%' (e.g. '%a%b%'), fall through to the full DP. | |||||
| 2601 | 12 | 25 | if($first_pct == 0 && $last_pct == $pat_len - 1 && $pat_len >= 3) { | |||
| 2602 | 7 | 8 | my $needle = substr($lc_pat, 1, $pat_len - 2); | |||
| 2603 | 7 | 9 | if(index($needle, '%') == -1) { | |||
| 2604 | 3 | 7 | return index($lc_str, $needle) >= 0; | |||
| 2605 | } | |||||
| 2606 | } | |||||
| 2607 | } | |||||
| 2608 | ||||||
| 2609 | # Full DP â O(m*n) time, O(m) memory. | |||||
| 2610 | # Two 1-D arrayrefs (@$prev, @$curr) replace the O(m*n) 2-D table. | |||||
| 2611 | # substr() replaces split(//) â no per-char scalar allocation. | |||||
| 2612 | # Ref-swap ($prev,$curr) = ($curr,$prev) at the end of each outer iteration | |||||
| 2613 | # avoids the O(m) array copy that "@prev = @curr" would perform. | |||||
| 2614 | 13 | 10 | my $m = $str_len; | |||
| 2615 | 13 | 7 | my $n = $pat_len; | |||
| 2616 | ||||||
| 2617 | 13 | 37 | my ($prev, $curr) = ([1, (0) x $m], [(0) x ($m + 1)]); | |||
| 2618 | ||||||
| 2619 | 13 | 16 | for my $i (1 .. $n) { | |||
| 2620 | 207 207 | 138 505 | @{$curr} = (0) x ($m + 1); # zero in-place â reuses existing allocation | |||
| 2621 | 207 | 132 | my $pc = substr($lc_pat, $i - 1, 1); | |||
| 2622 | 207 | 151 | if($pc eq '%') { | |||
| 2623 | 119 | 78 | $curr->[0] = $prev->[0]; | |||
| 2624 | 119 | 76 | for my $j (1 .. $m) { | |||
| 2625 | 9572 | 8016 | $curr->[$j] = ($prev->[$j] || $curr->[$j - 1]) ? 1 : 0; | |||
| 2626 | } | |||||
| 2627 | } else { | |||||
| 2628 | 88 | 55 | for my $j (1 .. $m) { | |||
| 2629 | 9099 | 8723 | $curr->[$j] = ($prev->[$j - 1] | |||
| 2630 | && ($pc eq '_' || $pc eq substr($lc_str, $j - 1, 1))) ? 1 : 0; | |||||
| 2631 | } | |||||
| 2632 | } | |||||
| 2633 | 207 | 161 | ($prev, $curr) = ($curr, $prev); # O(1) ref swap â no array copy | |||
| 2634 | } | |||||
| 2635 | 13 | 31 | return $prev->[$m]; | |||
| 2636 | } | |||||
| 2637 | ||||||
| 2638 | sub _match_criterion | |||||
| 2639 | { | |||||
| 2640 | 161 | 605 | my ($self, $row_val, $crit_val) = @_; | |||
| 2641 | ||||||
| 2642 | 161 | 181 | if(ref($crit_val) eq 'HASH') { | |||
| 2643 | 66 66 | 53 87 | for my $op (keys %{$crit_val}) { | |||
| 2644 | 65 | 58 | my $operand = $crit_val->{$op}; | |||
| 2645 | 65 | 165 | if($op eq '-in') { | |||
| 2646 | 7 16 6 | 11 27 8 | return 0 unless defined($row_val) && grep { $row_val eq $_ } @{$operand}; | |||
| 2647 | } elsif($op eq '-not_in') { | |||||
| 2648 | 6 16 6 | 12 27 5 | return 0 if defined($row_val) && grep { $row_val eq $_ } @{$operand}; | |||
| 2649 | } elsif($op eq '-between') { | |||||
| 2650 | 10 | 41 | return 0 unless defined($row_val) && $row_val >= $operand->[0] && $row_val <= $operand->[1]; | |||
| 2651 | } elsif($op eq '-like') { | |||||
| 2652 | 9 | 14 | return 0 unless defined($row_val); | |||
| 2653 | 8 | 13 | return 0 unless _like_match($row_val, $operand); | |||
| 2654 | } elsif($op eq '-not_like') { | |||||
| 2655 | 5 | 14 | return 0 unless defined($row_val); | |||
| 2656 | 4 | 6 | return 0 if _like_match($row_val, $operand); | |||
| 2657 | } elsif($op eq '!=') { | |||||
| 2658 | 12 | 14 | if(!defined($operand)) { | |||
| 2659 | 5 | 12 | return 0 unless defined($row_val); | |||
| 2660 | } else { | |||||
| 2661 | 7 | 27 | return 0 unless defined($row_val) && $row_val ne $operand; | |||
| 2662 | } | |||||
| 2663 | } elsif($op eq '>') { | |||||
| 2664 | 7 | 24 | return 0 unless defined($row_val) && $row_val > $operand; | |||
| 2665 | } elsif($op eq '<') { | |||||
| 2666 | 3 | 10 | return 0 unless defined($row_val) && $row_val < $operand; | |||
| 2667 | } elsif($op eq '>=') { | |||||
| 2668 | 3 | 11 | return 0 unless defined($row_val) && $row_val >= $operand; | |||
| 2669 | } elsif($op eq '<=') { | |||||
| 2670 | 3 | 13 | return 0 unless defined($row_val) && $row_val <= $operand; | |||
| 2671 | } | |||||
| 2672 | } | |||||
| 2673 | 35 | 89 | return 1; | |||
| 2674 | } | |||||
| 2675 | ||||||
| 2676 | 95 | 296 | return !defined($row_val) && !defined($crit_val) ? 1 | |||
| 2677 | : !defined($row_val) || !defined($crit_val) ? 0 | |||||
| 2678 | : $row_val eq $crit_val; | |||||
| 2679 | } | |||||
| 2680 | ||||||
| 2681 | # Determine the table and open the database | |||||
| 2682 | sub _open_table | |||||
| 2683 | { | |||||
| 2684 | 1313 | 1339 | my($self, $params) = @_; | |||
| 2685 | ||||||
| 2686 | # Derive the table name, caching the result in '_table_name' for the common | |||||
| 2687 | # case of no caller-supplied 'table' override. Avoids repeating ref()+regex | |||||
| 2688 | # on every query when the same object makes many calls. | |||||
| 2689 | 1313 | 844 | my $table; | |||
| 2690 | 1313 | 1381 | if($params->{'table'}) { | |||
| 2691 | 1 | 3 | ($table = $params->{'table'}) =~ s/\A.*:://; | |||
| 2692 | } else { | |||||
| 2693 | 1312 | 1901 | $table = $self->{'_table_name'} //= do { | |||
| 2694 | 293 | 548 | my $t = $self->{'table'} || ref($self); | |||
| 2695 | 293 | 697 | $t =~ s/\A.*:://; | |||
| 2696 | 293 | 496 | $t; | |||
| 2697 | }; | |||||
| 2698 | } | |||||
| 2699 | ||||||
| 2700 | # Open a connection if it's not already open. | |||||
| 2701 | # BerkeleyDB never sets $self->{$table} (no DBI handle) or $self->{'data'}, | |||||
| 2702 | # so we also guard on $self->{'berkeley'} to avoid re-tying on every call. | |||||
| 2703 | 1313 | 2404 | $self->_open() if(!$self->{$table} && !$self->{'data'} && !$self->{'berkeley'}); | |||
| 2704 | ||||||
| 2705 | 1285 | 1264 | return $table; | |||
| 2706 | } | |||||
| 2707 | ||||||
| 2708 | # Quote a SQL identifier using the current connection's dialect rules. | |||||
| 2709 | # Falls back to ANSI double-quoting when no connection is available. | |||||
| 2710 | sub _quote_identifier | |||||
| 2711 | { | |||||
| 2712 | 4 | 1107 | my ($self, $name) = @_; | |||
| 2713 | ||||||
| 2714 | 4 | 17 | my $table = $self->{'table'} || ref($self); | |||
| 2715 | 4 | 8 | $table =~ s/\A.*:://; | |||
| 2716 | 4 | 10 | if(my $dbh = $self->{$table}) { | |||
| 2717 | 1 | 6 | return $dbh->quote_identifier($name); | |||
| 2718 | } | |||||
| 2719 | 3 | 6 | return qq{"$name"}; | |||
| 2720 | } | |||||
| 2721 | ||||||
| 2722 | # Determine whether a given file is a valid Berkeley DB file. | |||||
| 2723 | # It combines a fast preliminary check with a more thorough validation step for accuracy. | |||||
| 2724 | # It looks for the magic number at both byte 0 and byte 12. | |||||
| 2725 | sub _is_berkeley_db { | |||||
| 2726 | 216 | 582 | my ($self, $file) = @_; | |||
| 2727 | ||||||
| 2728 | # Step 1: Check magic number | |||||
| 2729 | # no autodie here: the file may not exist, and we want a silent false return | |||||
| 2730 | 216 | 181 | my $fh; | |||
| 2731 | 35 35 35 216 216 | 39752 32 82 146 2398 | do { no autodie qw(open); open $fh, '<', $file } or return 0; | |||
| 2732 | 2 | 6 | binmode $fh; | |||
| 2733 | ||||||
| 2734 | 2 | 485 | my $is_db = $self->_has_bdb_magic($fh); | |||
| 2735 | 2 | 5 | close $fh; | |||
| 2736 | ||||||
| 2737 | 2 | 377 | if($is_db) { | |||
| 2738 | # Step 2: Attempt to open as Berkeley DB | |||||
| 2739 | ||||||
| 2740 | 0 | 0 | require DB_File; | |||
| 2741 | ||||||
| 2742 | 0 | 0 | my %bdb; | |||
| 2743 | 0 | 0 | if(tie %bdb, 'DB_File', $file, O_RDONLY, 0644, $DB_File::DB_HASH) { | |||
| 2744 | # untie %db; | |||||
| 2745 | 0 | 0 | $self->{'berkeley'} = \%bdb; | |||
| 2746 | 0 | 0 | return 1; # Successfully identified as a Berkeley DB file | |||
| 2747 | } | |||||
| 2748 | } | |||||
| 2749 | 2 | 5 | return 0; | |||
| 2750 | } | |||||
| 2751 | ||||||
| 2752 | # Check for Berkeley DB magic bytes at offsets 0 and 12. | |||||
| 2753 | # Returns true if either location contains a recognised BDB magic number. | |||||
| 2754 | sub _has_bdb_magic { | |||||
| 2755 | 8 | 1608 | my ($self, $fh) = @_; | |||
| 2756 | ||||||
| 2757 | # Offset 0: 32-bit magic number in both endian forms | |||||
| 2758 | 8 | 14 | read($fh, my $buf, 4) == 4 or return 0; | |||
| 2759 | 7 28 | 717 32 | my %magic = map { $_ => 1 } (0x00061561, 0x00053162, 0x00042253, 0x00052444); | |||
| 2760 | 7 | 37 | return 1 if $magic{unpack('N', $buf)} || $magic{unpack('V', $buf)}; | |||
| 2761 | ||||||
| 2762 | # Offset 12: Btree magic prefix (fallback for some BDB file variants) | |||||
| 2763 | 4 | 21 | seek $fh, 12, 0 or return 0; | |||
| 2764 | 4 | 513 | read($fh, $buf, 4) or return 0; | |||
| 2765 | 3 | 81 | my $hex12 = substr(unpack('H*', $buf), 0, 4); | |||
| 2766 | 3 | 10 | return($hex12 eq '6115' || $hex12 eq '1561'); | |||
| 2767 | } | |||||
| 2768 | ||||||
| 2769 | # Return true if $host refers to the current machine (localhost, loopback, or | |||||
| 2770 | # the machine's own hostname). Strips an optional user@ prefix first. | |||||
| 2771 | # Used by new() and _open() to decide whether to use local file access instead | |||||
| 2772 | # of File::Slurp::Remote, so the caller never loads that module unnecessarily. | |||||
| 2773 | sub _is_local_host { | |||||
| 2774 | 53 | 489 | my ($self, $host) = @_; | |||
| 2775 | ||||||
| 2776 | # Strip optional user@ prefix. \A (not ^) so a newline cannot split the match. | |||||
| 2777 | 53 | 85 | (my $bare = $host) =~ s/\A[^@]*@//; | |||
| 2778 | ||||||
| 2779 | # \z anchors at true end-of-string; $ would match before a trailing newline. | |||||
| 2780 | 53 | 145 | return 1 if $bare =~ /\A(?:localhost|127\.0\.0\.1|::1)\z/i; | |||
| 2781 | ||||||
| 2782 | 21 | 42 | require Sys::Hostname; | |||
| 2783 | 21 | 47 | my $me = lc(Sys::Hostname::hostname()); | |||
| 2784 | 21 | 56 | my $lc_bare = lc($bare); | |||
| 2785 | 21 | 32 | return 1 if $lc_bare eq $me; | |||
| 2786 | ||||||
| 2787 | # Match on short hostname: 'mybox' matches 'mybox.example.com' and vice-versa | |||||
| 2788 | 13 | 16 | (my $me_short = $me) =~ s/\..*//; | |||
| 2789 | 13 | 16 | (my $bare_short = $lc_bare) =~ s/\..*//; | |||
| 2790 | 13 | 27 | return($bare_short eq $me_short); | |||
| 2791 | } | |||||
| 2792 | ||||||
| 2793 | # Determine whether a given file is a DBM::Deep file by checking its magic bytes. | |||||
| 2794 | # The standard DBM::Deep magic is 'DPDB' (0x44 0x50 0x44 0x42); 'DPDP' (0x44 0x50 0x44 0x50) | |||||
| 2795 | # is also accepted for compatibility with files created by alternative tooling. | |||||
| 2796 | # Returns 1 if the first 4 bytes match a known DBM::Deep signature, 0 otherwise. | |||||
| 2797 | sub _is_deep_db { | |||||
| 2798 | 12 | 3816 | my ($self, $file) = @_; | |||
| 2799 | ||||||
| 2800 | 12 | 11 | my $fh; | |||
| 2801 | 35 35 35 12 12 | 12058 34 66 6 129 | do { no autodie qw(open); open $fh, '<', $file } or return 0; | |||
| 2802 | 10 | 20 | binmode $fh; | |||
| 2803 | 10 | 1095 | my $n = read($fh, my $magic, 4); | |||
| 2804 | 10 | 983 | close $fh; | |||
| 2805 | 10 | 287 | return 0 unless defined($n) && $n == 4; | |||
| 2806 | ||||||
| 2807 | 8 | 27 | return($magic eq 'DPDB' || $magic eq 'DPDP'); | |||
| 2808 | } | |||||
| 2809 | ||||||
| 2810 | # Log and remember a message | |||||
| 2811 | sub _log | |||||
| 2812 | { | |||||
| 2813 | 2128 | 2289 | my ($self, $level, @messages) = @_; | |||
| 2814 | ||||||
| 2815 | # FIXME: add caller's function | |||||
| 2816 | # if(($level eq 'warn') || ($level eq 'notice')) { | |||||
| 2817 | 2128 2128 | 1349 5103 | push @{$self->{'messages'}}, { level => $level, message => join('', grep defined, @messages) }; | |||
| 2818 | # } | |||||
| 2819 | ||||||
| 2820 | 2128 | 3666 | if(scalar(@messages) && (my $logger = $self->{'logger'})) { | |||
| 2821 | 2128 | 4220 | $self->{'logger'}->$level(join('', grep defined, @messages)); | |||
| 2822 | } | |||||
| 2823 | } | |||||
| 2824 | ||||||
| 2825 | sub _debug { | |||||
| 2826 | 1547 | 3369 | my $self = shift; | |||
| 2827 | 1547 | 1698 | $self->_log('debug', @_); | |||
| 2828 | } | |||||
| 2829 | ||||||
| 2830 | sub _trace { | |||||
| 2831 | 577 | 1031 | my $self = shift; | |||
| 2832 | 577 | 831 | $self->_log('trace', @_); | |||
| 2833 | } | |||||
| 2834 | ||||||
| 2835 | # Emit a warning message somewhere | |||||
| 2836 | sub _warn { | |||||
| 2837 | 1 | 281 | my $self = shift; | |||
| 2838 | 1 | 2 | my $params = Params::Get::get_params('warning', \@_); | |||
| 2839 | ||||||
| 2840 | 1 | 16 | $self->_log('warn', $params->{'warning'}); | |||
| 2841 | 1 | 138 | Carp::carp(join('', grep defined, $params->{'warning'})); | |||
| 2842 | } | |||||
| 2843 | ||||||
| 2844 | # Die | |||||
| 2845 | sub _fatal { | |||||
| 2846 | 3 | 360 | my $self = shift; | |||
| 2847 | 3 | 8 | my $params = Params::Get::get_params('warning', \@_); | |||
| 2848 | ||||||
| 2849 | 3 | 52 | $self->_log('error', $params->{'warning'}); | |||
| 2850 | 3 | 679 | Carp::croak(join('', grep defined, $params->{'warning'})); | |||
| 2851 | } | |||||
| 2852 | ||||||
| 2853 - 3009 | =head1 AUTHOR Nigel Horne, C<< <njh at nigelhorne.com> >> =head1 SUPPORT This module is provided as-is without any warranty. Please report any bugs or feature requests to C<bug-database-abstraction at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Database-Abstraction>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 MESSAGES The table below lists every error that the module can croak or carp, what triggers it, and how to resolve it. =over 4 =item C<< I<Class>: abstract class >> Direct instantiation of C<Database::Abstraction> was attempted. Create a subclass and instantiate that instead. =item C<< I<Class>: where are the files? >> Neither C<directory> nor C<dsn> was supplied to C<new()>. =item C<< I<Class>: I</path> is not a directory >> The C<directory> argument exists on disk but is not a directory. =item C<< I<Class>: cannot connect: I<$DBI::errstr> >> DBI failed to connect to the given C<dsn>. Check credentials and host. =item C<< Can't find a file called 'I<name>' for the table I<T> in I<dir> >> None of the probe extensions (C<.sql>, C<.psv>, C<.csv>, C<.xlsx>, C<.db>, C<.xml>) matched in C<directory>. =item C<< I<Class>: prepare failed: I<$errstr> >> C<prepare_cached()> returned false. Usually a syntax error in an internally built query; file a bug if you see this from a normal API call. =item C<< _build_where_conditions: unsafe column name 'I<name>' >> A criteria key contained characters outside C<[A-Za-z0-9_.]>. This is a SQL-injection guard. Use only valid SQL identifier characters. =item C<< join: missing "table" >> / C<< join: missing "on" condition >> A join spec hashref is incomplete. Both C<table> and C<on> are required. =item C<< Invalid JOIN type: I<TYPE> >> C<type> in a join spec was not one of C<INNER LEFT RIGHT FULL CROSS>. =item C<< I<Class>: Unknown column I<col> >> / C<< I<Class>: AUTOLOAD disabled >> An AUTOLOAD call was made for a column that does not exist, or AUTOLOAD was disabled with C<< auto_load => 0 >>. =item C<< Usage: set_logger(logger => $logger) >> C<set_logger()> was called without a C<logger> argument. =item C<< Usage: execute(query => $query) >> C<execute()> was called without a C<query> argument. =item C<< XML slurp: I<...> is not yet supported >> The XML file structure is too complex for slurp mode. Use C<< max_slurp_size => 0 >> to force the DBI/XMLSimple SQL path. =item C<< I<Class>: I<method> is meaningless on a NoSQL database >> A relational method (C<selectall_arrayref>, C<count>, C<execute>, etc.) was called on a BerkeleyDB backend, which only supports key-value lookup via C<fetchrow_hashref>. =back =head1 KNOWN LIMITATIONS =over 4 =item * B<Read-only.> No INSERT, UPDATE, or DELETE is provided. C<execute()> runs raw read-only SQL. =item * B<Default CSV separator is C<!>>, not C<,>, for historical reasons. Pass C<< sep_char => ',' >> for standard RFC 4180 files. =item * B<Primary-key column is named C<entry>>, not C<key>, because C<key> is a SQL reserved word. Override with the C<id> parameter. =item * B<XML slurp is limited.> Only simple flat XML structures are supported in slurp mode. Multi-key or deeply nested documents will croak. Force SQL mode with C<< max_slurp_size => 0 >> if slurp fails. =item * B<Unique key assumption in slurp mode.> Duplicate values in the key column silently overwrite earlier rows. Disable slurp with C<< max_slurp_size => 0 >> if duplicates are expected. =item * B<BerkeleyDB does not support joins or the chained query builder.> =item * B<Column names must be valid SQL identifiers> (letters, digits, underscores, and a single dot for C<table.column> join notation). Other characters will cause a croak. =item * B<count() cache is opportunistic.> Count results are served from cache only when a prior C<selectall_arrayref()> or C<count()> call with the same criteria has already populated it. =back =head1 SEE ALSO =over 4 =item * L<Database::Abstraction::Query> - chained query builder =item * L<Configure an Object at Runtime|Object::Configure> =item * L<Test Dashboard|https://nigelhorne.github.io/Database-Abstraction/coverage/> =back =head1 LICENSE AND COPYRIGHT Copyright 2015-2026 Nigel Horne. Usage is subject to the GPL2 licence terms. If you use it, please let me know. =cut | |||||
| 3010 | ||||||
| 3011 | 1; | |||||