File Coverage

File:blib/lib/Database/Abstraction.pm
Coverage:75.3%

linestmtbrancondsubtimecode
1package 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
47our %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.
54my $SAFE_IDENTIFIER = qr/\A[a-zA-Z_][a-zA-Z0-9_]*\z/;
55my $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.
59my %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
71our $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
376sub 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
403sub 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
584sub 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
689sub 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
709sub _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
1188sub 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
1324sub 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
1345sub 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
1478sub 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
1496sub 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
1621sub 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
1750sub 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
1809sub 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
1838sub 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
1913sub 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
2002sub 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
2055sub 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
2263sub 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).
2307sub _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.
2329sub _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.
2349sub _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
2373sub _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.).
2437sub _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).
2506sub _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.
2561sub _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
2638sub _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
2682sub _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.
2710sub _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.
2725sub _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.
2754sub _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.
2773sub _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.
2797sub _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
2811sub _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
2825sub _debug {
2826
1547
3369
        my $self = shift;
2827
1547
1698
        $self->_log('debug', @_);
2828}
2829
2830sub _trace {
2831
577
1031
        my $self = shift;
2832
577
831
        $self->_log('trace', @_);
2833}
2834
2835# Emit a warning message somewhere
2836sub _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
2845sub _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
30111;