File Coverage

File:blib/lib/Database/Abstraction/Query.pm
Coverage:68.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
6
6
6
1657
6
103
use strict;
8
6
6
6
11
5
186
use warnings;
9
10
6
6
6
12
4
182
use Carp;
11
6
6
6
12
7
4294
use Scalar::Util qw(blessed);
12
13 - 21
=head1 NAME

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

=head1 VERSION

Version 0.36

=cut
22
23our $VERSION = '0.36';
24
25 - 111
=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
112
113 - 120
=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
121
122sub new
123{
124
61
1288
        my ($class, %args) = @_;
125
126
61
112
        my $db = $args{'_db'}
127                or croak('Database::Abstraction::Query: _db is required');
128
129
59
239
        croak('Database::Abstraction::Query: _db must be a Database::Abstraction object')
130                unless blessed($db) && $db->isa('Database::Abstraction');
131
132
57
220
        return bless {
133                _db       => $db,
134                _select   => '*',
135                _where    => {},
136                _joins    => [],
137                _order_by => undef,
138                _limit    => undef,
139                _offset   => undef,
140        }, $class;
141}
142
143 - 151
=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
152
153sub select
154{
155
5
3671
        my ($self, $cols) = @_;
156
5
12
        $self->{'_select'} = defined($cols) ? $cols : '*';
157
5
10
        return $self;
158}
159
160 - 177
=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
178
179sub where
180{
181
30
25
        my $self = shift;
182
30
0
51
0
        my %criteria = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_;
183
30
38
        for my $k (keys %criteria) {
184
30
35
                $self->{'_where'}{$k} = $criteria{$k};
185        }
186
30
57
        return $self;
187}
188
189 - 213
=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
214
215sub join        ## no critic(ProhibitBuiltinHomonyms)
216{
217
6
11
        my ($self, $spec) = @_;
218
6
0
13
0
        my @specs = ref($spec) eq 'ARRAY' ? @{$spec} : ($spec);
219
6
6
6
10
        push @{$self->{'_joins'}}, @specs;
220
6
31
        return $self;
221}
222
223 - 231
=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
232
233sub order_by
234{
235
15
17
        my ($self, $col) = @_;
236
15
15
        $self->{'_order_by'} = $col;
237
15
22
        return $self;
238}
239
240 - 246
=head2 limit

    $q->limit(20);

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

=cut
247
248sub limit
249{
250
13
14
        my ($self, $n) = @_;
251
13
12
        $self->{'_limit'} = $n;
252
13
16
        return $self;
253}
254
255 - 261
=head2 offset

    $q->offset(40);

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

=cut
262
263sub offset
264{
265
8
12
        my ($self, $n) = @_;
266
8
9
        $self->{'_offset'} = $n;
267
8
48
        return $self;
268}
269
270# Apply Perl-side sort, offset, and limit to an arrayref of rows in place.
271# Used by the BerkeleyDB execution paths in all() and first().
272# order_by must be a single "column [ASC|DESC]" string (multi-column not supported).
273sub _apply_perl_sort_limit
274{
275
0
0
        my ($rows, $order_by, $offset, $limit) = @_;
276
277
0
0
        if(defined $order_by) {
278
0
0
                my ($col, $dir) = ($order_by =~ /^(\S+)(?:\s+(ASC|DESC))?$/i);
279
0
0
                $dir //= 'ASC';
280
0
0
                @{$rows} = sort {
281                        $dir =~ /DESC/i
282                                ? (($b->{$col} // '') cmp ($a->{$col} // ''))
283
0
0
                                : (($a->{$col} // '') cmp ($b->{$col} // ''))
284
0
0
0
0
                } @{$rows};
285        }
286
0
0
0
0
        splice(@{$rows}, 0, $offset) if $offset;
287
0
0
0
0
        splice(@{$rows}, $limit)     if defined $limit;
288}
289
290# Internal: assemble SQL + bind args.  $count_only replaces SELECT cols with COUNT(*).
291sub _build_sql
292{
293
52
82
        my ($self, $count_only) = @_;
294
295
52
43
        my $db    = $self->{'_db'};
296
52
84
        my $table = $db->{'table'} || ref($db);
297
52
77
        $table =~ s/.*:://;
298
299        # Ensure the underlying table connection is open
300
52
67
        $db->_open_table({});
301
302
52
59
        my $select = $count_only ? 'COUNT(*)' : $self->{'_select'};
303
52
44
        my $query  = "SELECT $select FROM $table";
304
305
52
52
32
55
        if(@{$self->{'_joins'}}) {
306
3
13
                $query .= ' ' . $db->_build_joins($self->{'_joins'});
307        }
308
309
52
111
        my ($where, $wargs) = $db->_build_where($self->{'_where'});
310
52
52
36
47
        my @args = @{$wargs};
311
312
52
52
39
83
        if(@{$self->{'_joins'}}) {
313
3
5
                $query .= " WHERE $where" if $where;
314        } elsif(($db->{'type'} eq 'CSV') && !$db->{'no_entry'}) {
315
2
2
                my $id = $db->{'id'};
316
2
3
                $query .= " WHERE $id IS NOT NULL AND $id NOT LIKE '#%'";
317
2
3
                $query .= " AND ($where)" if $where;
318        } else {
319
47
47
                $query .= " WHERE $where" if $where;
320        }
321
322
52
59
        unless($count_only) {
323
44
46
                $query .= " ORDER BY $self->{'_order_by'}" if defined $self->{'_order_by'};
324
44
51
                $query .= " LIMIT $self->{'_limit'}"       if defined $self->{'_limit'};
325
44
47
                $query .= " OFFSET $self->{'_offset'}"     if defined $self->{'_offset'};
326        }
327
328
52
86
        return ($query, \@args, $table);
329}
330
331 - 339
=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
340
341sub all
342{
343
36
371
        my $self = shift;
344
36
44
        my $db   = $self->{'_db'};
345
346        # Ensure _open() fires before checking the backend type.
347
36
68
        $db->_open_table({});
348
349
36
48
        if($db->{'berkeley'}) {
350                croak(ref($db), ': query->all() with JOINs is not supported on BerkeleyDB')
351
0
0
0
0
                        if @{$self->{'_joins'}};
352
0
0
0
0
                my $rows = $db->selectall_arrayref({%{$self->{'_where'}}});
353
0
0
                _apply_perl_sort_limit($rows, $self->{'_order_by'}, $self->{'_offset'}, $self->{'_limit'});
354
0
0
                return $rows;
355        }
356
357
36
45
        my ($query, $args, $table) = $self->_build_sql(0);
358
36
69
        $db->_debug("Query->all: $query");
359
360
36
766
        my $sth = $db->{$table}->prepare_cached($query);
361
36
0
36
7973
0
682
        $sth->execute(@{$args}) or croak("$query: @{$args}");
362
363
36
2847
        my @rows;
364
36
307
        while(my $row = $sth->fetchrow_hashref()) {
365
110
793
                push @rows, $row;
366        }
367
36
105
        return \@rows;
368}
369
370 - 379
=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
380
381sub first
382{
383
8
7
        my $self = shift;
384
8
8
        my $db   = $self->{'_db'};
385
386
8
14
        $db->_open_table({});
387
388
8
11
        if($db->{'berkeley'}) {
389                croak(ref($db), ': query->first() with JOINs is not supported on BerkeleyDB')
390
0
0
0
0
                        if @{$self->{'_joins'}};
391
0
0
0
0
                my $rows = $db->selectall_arrayref({%{$self->{'_where'}}});
392
0
0
                _apply_perl_sort_limit($rows, $self->{'_order_by'}, $self->{'_offset'}, undef);
393
0
0
                return $rows->[0];
394        }
395
396
8
8
        my $saved = $self->{'_limit'};
397
8
9
        $self->{'_limit'} = 1;
398
8
11
        my ($query, $args, $table) = $self->_build_sql(0);
399
8
9
        $self->{'_limit'} = $saved;
400
401
8
15
        $db->_debug("Query->first: $query");
402
403
8
186
        my $sth = $db->{$table}->prepare_cached($query);
404
8
0
8
286
0
165
        $sth->execute(@{$args}) or croak("$query: @{$args}");
405
406
8
65
        my $row = $sth->fetchrow_hashref();
407
8
19
        $sth->finish();
408
8
15
        return $row;
409}
410
411 - 419
=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
420
421sub count
422{
423
8
42
        my $self = shift;
424
8
9
        my $db   = $self->{'_db'};
425
426
8
11
        $db->_open_table({});
427
428
8
12
        if($db->{'berkeley'}) {
429                croak(ref($db), ': query->count() with JOINs is not supported on BerkeleyDB')
430
0
0
0
0
                        if @{$self->{'_joins'}};
431
0
0
0
0
                return $db->count({%{$self->{'_where'}}});
432        }
433
434
8
10
        my ($query, $args, $table) = $self->_build_sql(1);
435
8
16
        $db->_debug("Query->count: $query");
436
437
8
160
        my $sth = $db->{$table}->prepare_cached($query);
438
8
0
8
199
0
118
        $sth->execute(@{$args}) or croak("$query: @{$args}");
439
440
8
39
        my $row = $sth->fetchrow_arrayref();
441
8
13
        $sth->finish();
442
8
20
        return $row ? $row->[0] : 0;
443}
444
445 - 464
=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.

=cut
465
4661;