| File: | blib/lib/Database/Abstraction/Query.pm |
| Coverage: | 93.4% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package 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 | ||||||
| 24 | our $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 | ||||||
| 123 | sub 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 | ||||||
| 154 | sub 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 | ||||||
| 180 | sub 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 | ||||||
| 216 | sub 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 | ||||||
| 234 | sub 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 | ||||||
| 259 | sub 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 | ||||||
| 279 | sub 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). | |||||
| 292 | sub _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(*). | |||||
| 315 | sub _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 | ||||||
| 365 | sub 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 | ||||||
| 406 | sub 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 | ||||||
| 448 | sub 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 | ||||||
| 496 | 1; | |||||