File Coverage

File:blib/lib/Database/Abstraction/Query.pm
Coverage:93.4%

linestmtbrancondsubtimecode
1package Database::Abstraction::Query;
2
3# Chained query builder for Database::Abstraction objects.
4# Returned by $db->query() and used as:
5#   $db->query->where(col => val)->order_by('col')->limit(10)->all()
6
7
11
11
11
1509
10
163
use strict;
8
11
11
11
17
11
256
use warnings;
9
11
11
11
41
11
40
use autodie qw(:all);
10
11
11
11
11
24079
10
336
use Carp;
12
11
11
11
23
24
9748
use Scalar::Util qw(blessed);
13
14 - 22
=head1 NAME

Database::Abstraction::Query - Fluent, chainable query builder for Database::Abstraction

=head1 VERSION

Version 0.41

=cut
23
24our $VERSION = '0.41';
25
26 - 112
=head1 SYNOPSIS

    my $db = Database::Foo->new(directory => '/path/to/data');

    # --- Basic usage -----------------------------------------------

    # All rows
    my $all = $db->query->all();

    # Filter, sort, page
    my $rows = $db->query
        ->where(status => 'active')
        ->where(score  => { '>=' => 80 })
        ->order_by('score DESC')
        ->limit(10)
        ->offset(20)
        ->all();

    # Single row
    my $row = $db->query->where(name => 'Alice')->first();

    # Count
    my $n = $db->query->where(status => 'active')->count();

    # --- Specific columns ------------------------------------------

    my $names = $db->query->select('name, score')->where(status => 'active')->all();

    # --- Joins -----------------------------------------------------

    my $joined = $db->query
        ->join({ table => 'dept', on => 'e.dept_id = dept.id', type => 'LEFT' })
        ->where(dept_name => 'Engineering')
        ->all();

    # --- OR criteria -----------------------------------------------

    my $either = $db->query
        ->where(-or => [
            { status => 'active'           },
            { score  => { '>=' => 95 }     },
        ])
        ->all();

=head1 DESCRIPTION

C<Database::Abstraction::Query> is a fluent query builder returned by
C<< $db->query() >>.  You assemble a query by chaining builder methods,
then execute it with a terminal method.

=over 4

=item *

B<Builder methods> (C<select>, C<where>, C<join>, C<order_by>, C<limit>,
C<offset>) all return C<$self>, so calls can be chained in any order.

=item *

B<Terminal methods> (C<all>, C<first>, C<count>) assemble the SQL, execute
it, and return the result.  Each terminal method can be called on the same
builder object independently - calling C<first()> does not modify the stored
state (it temporarily sets LIMIT 1 internally).

=item *

C<where()> calls are B<merged with AND semantics>: each call adds more
required conditions.  To express OR conditions pass C<< -or => [...] >> as a
key inside a single C<where()> call.

=item *

The C<join> parameter accepts the same spec as the C<join> parameter in
L<Database::Abstraction/QUERY CRITERIA>.

=item *

BerkeleyDB backends support C<all()>, C<first()>, and C<count()> with
C<where()> criteria and C<order_by()>/C<limit()>/C<offset()> applied in Perl.
The C<join()> builder method and the C<select()> column projection are not
supported on BerkeleyDB and will raise an error.

=back

=head1 METHODS

=cut
113
114 - 121
=head2 new

    my $q = Database::Abstraction::Query->new(_db => $db_object);

Construct a new, empty query builder bound to C<$db_object>.  In practice
you almost always call this via C<< $db->query() >> instead.

=cut
122
123sub new
124{
125
136
1260
        my ($class, %args) = @_;
126
127
136
215
        my $db = $args{'_db'}
128                or croak('Database::Abstraction::Query: _db is required');
129
130
134
521
        croak('Database::Abstraction::Query: _db must be a Database::Abstraction object')
131                unless blessed($db) && $db->isa('Database::Abstraction');
132
133
132
524
        return bless {
134                _db       => $db,
135                _select   => '*',
136                _where    => {},
137                _joins    => [],
138                _order_by => undef,
139                _limit    => undef,
140                _offset   => undef,
141        }, $class;
142}
143
144 - 152
=head2 select

    $q->select('name, score');
    $q->select('COUNT(*) AS n, status');

Set the column expression for the C<SELECT> clause.  Default is C<*> (all
columns).  Returns C<$self>.

=cut
153
154sub select
155{
156
5
3579
        my ($self, $cols) = @_;
157
5
10
        $self->{'_select'} = defined($cols) ? $cols : '*';
158
5
7
        return $self;
159}
160
161 - 178
=head2 where

    $q->where(status => 'active');
    $q->where(score  => { '>'  => 8     });
    $q->where(name   => { -in  => [...] });
    $q->where(-or    => [ {...}, {...}     ]);

Add one or more criteria to the query.  Multiple calls are merged with
AND semantics.  Accepts a flat list of key/value pairs or a single hashref.

Supports the full criteria syntax of L<Database::Abstraction/QUERY CRITERIA>:
plain scalars, wildcard strings, C<undef> (IS NULL), comparison operator
hashrefs (C<< { '>' => n } >>), C<-in>, C<-not_in>, C<-between>,
C<-like>, C<-not_like>, C<-or>, and C<-and>.

Returns C<$self>.

=cut
179
180sub where
181{
182
61
51
        my $self = shift;
183
61
5
99
5
        my %criteria = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_;
184
61
94
        for my $k (keys %criteria) {
185
60
81
                $self->{'_where'}{$k} = $criteria{$k};
186        }
187
61
103
        return $self;
188}
189
190 - 214
=head2 join

    $q->join({ table => 'dept', on => 'e.dept_id = dept.id', type => 'LEFT' });

    # Multiple joins at once
    $q->join([
        { table => 'dept',    on => 'e.dept_id    = dept.id'    },
        { table => 'country', on => 'e.country_id = country.id' },
    ]);

Append one or more JOIN specs.  Each spec is a hashref with:

=over 4

=item * C<table> - the table to join (required)

=item * C<on> - the join condition, verbatim SQL (required)

=item * C<type> - join type: C<INNER> (default), C<LEFT>, C<RIGHT>, C<FULL>, C<CROSS>

=back

Multiple calls accumulate joins.  Returns C<$self>.

=cut
215
216sub join        ## no critic(ProhibitBuiltinHomonyms)
217{
218
16
296
        my ($self, $spec) = @_;
219
16
1
31
1
        my @specs = ref($spec) eq 'ARRAY' ? @{$spec} : ($spec);
220
16
16
12
23
        push @{$self->{'_joins'}}, @specs;
221
16
25
        return $self;
222}
223
224 - 232
=head2 order_by

    $q->order_by('name DESC');
    $q->order_by('score DESC, name ASC');

Set the C<ORDER BY> expression.  Replaces any previously set ordering.
Returns C<$self>.

=cut
233
234sub order_by
235{
236
25
26
        my ($self, $col) = @_;
237        # Guard the three primary SQL injection vectors before the value is
238        # interpolated verbatim into ORDER BY $col (see _build_sql).  The check
239        # is deliberately permissive so it does not break legitimate multi-column
240        # expressions ("score DESC, name ASC") or SQL functions ("ABS(score) DESC").
241
25
30
        if(defined $col) {
242                # Block the three primary SQL injection vectors that can appear inside
243                # an ORDER BY expression.  Use m{} to avoid escaping '/' and '\*'.
244
24
69
                croak("order_by: unsafe ORDER BY expression '$col'")
245                        if $col =~ m{; | -- | /\*}x;
246        }
247
22
25
        $self->{'_order_by'} = $col;
248
22
34
        return $self;
249}
250
251 - 257
=head2 limit

    $q->limit(20);

Set the maximum number of rows to return.  Returns C<$self>.

=cut
258
259sub limit
260{
261
32
30
        my ($self, $n) = @_;
262        # Validate at the setter: LIMIT must be a non-negative integer.
263        # Direct interpolation into SQL (line: LIMIT $n) makes any non-integer a
264        # potential injection vector (e.g. "10; DROP TABLE users").
265
32
129
        croak("limit: value must be a non-negative integer")
266                if !defined($n) || $n !~ /\A\d+\z/;
267
28
53
        $self->{'_limit'} = int($n);
268
28
36
        return $self;
269}
270
271 - 277
=head2 offset

    $q->offset(40);

Skip the first N rows (for pagination with L</limit>).  Returns C<$self>.

=cut
278
279sub offset
280{
281
17
19
        my ($self, $n) = @_;
282        # Same guard as limit(): OFFSET is interpolated directly into SQL.
283
17
88
        croak("offset: value must be a non-negative integer")
284                if !defined($n) || $n !~ /\A\d+\z/;
285
14
16
        $self->{'_offset'} = int($n);
286
14
18
        return $self;
287}
288
289# Apply Perl-side sort, offset, and limit to an arrayref of rows in place.
290# Used by the BerkeleyDB execution paths in all() and first().
291# order_by must be a single "column [ASC|DESC]" string (multi-column not supported).
292sub _apply_perl_sort_limit
293{
294
14
2426
        my ($rows, $order_by, $offset, $limit) = @_;
295
296
14
17
        if(defined $order_by) {
297                # Use \z (true end-of-string) not $ (matches before a trailing newline).
298                # (ASC|DESC) is already a non-regex check after capture; $dir is either
299                # 'ASC', 'DESC', or undef — hoist the direction decision out of the sort
300                # comparator so it is not evaluated O(N log N) times for an N-row result.
301
4
14
                my ($col, $dir) = ($order_by =~ /\A(\S+)(?:\s+(ASC|DESC))?\z/i);
302
4
6
                $dir //= 'ASC';
303
4
4
                my $desc = ($dir eq 'DESC');    # evaluated once, not on every comparison
304
4
4
                @{$rows} = sort {
305                        $desc
306                                ? (($b->{$col} // '') cmp ($a->{$col} // ''))
307
14
22
                                : (($a->{$col} // '') cmp ($b->{$col} // ''))
308
4
4
3
7
                } @{$rows};
309        }
310
14
2
15
2
        splice(@{$rows}, 0, $offset) if $offset;
311
14
3
15
5
        splice(@{$rows}, $limit)     if defined $limit;
312}
313
314# Internal: assemble SQL + bind args.  $count_only replaces SELECT cols with COUNT(*).
315sub _build_sql
316{
317
80
107
        my ($self, $count_only) = @_;
318
319
80
62
        my $db = $self->{'_db'};
320
321        # _open_table populates $db->{'_table_name'} as a side-effect, so call it
322        # first and then read the cache directly — avoids a second ref()+regex.
323
80
90
        $db->_open_table({});
324
80
70
        my $table = $db->{'_table_name'};
325
326
80
97
        my $select = $count_only ? 'COUNT(*)' : $self->{'_select'};
327
80
80
        my $query  = "SELECT $select FROM $table";
328
329
80
80
80
88
        if(@{$self->{'_joins'}}) {
330
4
15
                $query .= ' ' . $db->_build_joins($self->{'_joins'});
331        }
332
333
79
118
        my ($where, $wargs) = $db->_build_where($self->{'_where'});
334
78
78
71
111
        my @args = @{$wargs};
335
336
78
78
54
132
        if(@{$self->{'_joins'}}) {
337
3
6
                $query .= " WHERE $where" if $where;
338        } elsif(($db->{'type'} eq 'CSV') && !$db->{'no_entry'}) {
339
12
12
                my $id = $db->{'id'};
340
12
12
                $query .= " WHERE $id IS NOT NULL AND $id NOT LIKE '#%'";
341
12
20
                $query .= " AND ($where)" if $where;
342        } else {
343
63
63
                $query .= " WHERE $where" if $where;
344        }
345
346
78
75
        unless($count_only) {
347
62
60
                $query .= " ORDER BY $self->{'_order_by'}" if defined $self->{'_order_by'};
348
62
67
                $query .= " LIMIT $self->{'_limit'}"       if defined $self->{'_limit'};
349
62
61
                $query .= " OFFSET $self->{'_offset'}"     if defined $self->{'_offset'};
350        }
351
352
78
129
        return ($query, \@args, $table);
353}
354
355 - 363
=head2 all

    my $rows = $q->all();

B<Terminal method.>  Executes the assembled query and returns an array
reference of hash references, one per matching row.  Returns an empty
array reference when there are no matches (never C<undef>).

=cut
364
365sub all
366{
367
57
492
        my $self = shift;
368
57
57
        my $db   = $self->{'_db'};
369
370        # Ensure _open() fires before checking the backend type.
371
57
89
        $db->_open_table({});
372
373
57
146
        if($db->{'berkeley'} || ($db->{'type'} // '') eq 'Deep') {
374
8
12
                my $backend = $db->{'berkeley'} ? 'BerkeleyDB' : 'Deep';
375                croak(ref($db), ": query->all() with JOINs is not supported on $backend")
376
8
8
6
43
                        if @{$self->{'_joins'}};
377
5
5
4
10
                my $rows = $db->selectall_arrayref({%{$self->{'_where'}}});
378
5
281
                _apply_perl_sort_limit($rows, $self->{'_order_by'}, $self->{'_offset'}, $self->{'_limit'});
379
5
6
                return $rows;
380        }
381
382
49
57
        my ($query, $args, $table) = $self->_build_sql(0);
383
47
86
        $db->_debug("Query->all: $query");
384
385
47
1094
        my $sth = $db->{$table}->prepare_cached($query);
386
47
0
47
12276
0
834
        $sth->execute(@{$args}) or croak("$query: @{$args}");
387
388
47
7069
        my @rows;
389
47
382
        while(my $row = $sth->fetchrow_hashref()) {
390
122
887
                push @rows, $row;
391        }
392
47
225
        return \@rows;
393}
394
395 - 404
=head2 first

    my $row = $q->first();    # \%hashref or undef

B<Terminal method.>  Executes the query with C<LIMIT 1> and returns the
first matching row as a hash reference, or C<undef> when there is no match.
Any C<limit()> or C<offset()> you have set is temporarily overridden for
efficiency (only the LIMIT is overridden; offset is still applied).

=cut
405
406sub first
407{
408
18
178
        my $self = shift;
409
18
46
        my $db   = $self->{'_db'};
410
411
18
31
        $db->_open_table({});
412
413
18
50
        if($db->{'berkeley'} || ($db->{'type'} // '') eq 'Deep') {
414
6
11
                my $backend = $db->{'berkeley'} ? 'BerkeleyDB' : 'Deep';
415                croak(ref($db), ": query->first() with JOINs is not supported on $backend")
416
6
6
4
29
                        if @{$self->{'_joins'}};
417
4
4
4
7
                my $rows = $db->selectall_arrayref({%{$self->{'_where'}}});
418
4
228
                _apply_perl_sort_limit($rows, $self->{'_order_by'}, $self->{'_offset'}, undef);
419
4
9
                return $rows->[0];
420        }
421
422        # local on a hash element (supported since Perl 5.8.1) is exception-safe:
423        # even if _build_sql() croaks, _limit is automatically restored on unwind.
424        # The previous save/restore pair left _limit permanently at 1 on exception.
425
12
16
        local $self->{'_limit'} = 1;
426
12
15
        my ($query, $args, $table) = $self->_build_sql(0);
427
428
12
25
        $db->_debug("Query->first: $query");
429
430
12
259
        my $sth = $db->{$table}->prepare_cached($query);
431
12
0
12
3874
0
199
        $sth->execute(@{$args}) or croak("$query: @{$args}");
432
433
12
2605
        my $row = $sth->fetchrow_hashref();
434
12
113
        $sth->finish();
435
12
34
        return $row;
436}
437
438 - 446
=head2 count

    my $n = $q->count();

B<Terminal method.>  Executes C<SELECT COUNT(*)> with the current C<WHERE>
and C<JOIN> clauses and returns the integer count.  C<ORDER BY>, C<LIMIT>,
and C<OFFSET> are ignored for the count query.

=cut
447
448sub count
449{
450
20
22
        my $self = shift;
451
20
17
        my $db   = $self->{'_db'};
452
453
20
35
        $db->_open_table({});
454
455
20
51
        if($db->{'berkeley'} || ($db->{'type'} // '') eq 'Deep') {
456
5
6
                my $backend = $db->{'berkeley'} ? 'BerkeleyDB' : 'Deep';
457                croak(ref($db), ": query->count() with JOINs is not supported on $backend")
458
5
5
5
27
                        if @{$self->{'_joins'}};
459
3
3
4
8
                return $db->count({%{$self->{'_where'}}});
460        }
461
462
15
19
        my ($query, $args, $table) = $self->_build_sql(1);
463
15
33
        $db->_debug("Query->count: $query");
464
465
15
306
        my $sth = $db->{$table}->prepare_cached($query);
466
15
0
15
6431
0
194
        $sth->execute(@{$args}) or croak("$query: @{$args}");
467
468
15
3482
        my $row = $sth->fetchrow_arrayref();
469
15
83
        $sth->finish();
470
15
63
        return $row ? $row->[0] : 0;
471}
472
473 - 494
=head1 SEE ALSO

L<Database::Abstraction> - the parent module and its L<Database::Abstraction/QUERY CRITERIA> section.

=head1 AUTHOR

Nigel Horne, C<< <njh at nigelhorne.com> >>

=head1 SUPPORT

Please report bugs at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Database-Abstraction>.

=head1 LICENSE AND COPYRIGHT

Copyright 2026 Nigel Horne.

Usage is subject to the GPL2 licence terms.
If you use it,
please let me know.

=cut
495
4961;