lib/Database/Abstraction/Query.pm

⬅ Previous Index
Structural Coverage (Approximate)

TER1 (Statement): 97.92%
TER2 (Branch): 93.24%
TER3 (LCSAJ): 100.0% (10/10)
Approximate LCSAJ segments: 75

LCSAJ Legend

● Covered — this LCSAJ path was executed during testing.

● Not covered — this LCSAJ path was never executed. These are the paths to focus on.

Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows: 

        start → end → jump

Uncovered paths show [NOT COVERED] in the tooltip.

Mutant Testing Legend

Survived (tests missed this) Killed (tests detected this) No mutation 
    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: use strict;
    8: use warnings;
    9: use autodie qw(:all);
   10: 
   11: use Carp;
   12: use Scalar::Util qw(blessed);
   13: 
   14: =head1 NAME
   15: 
   16: Database::Abstraction::Query - Fluent, chainable query builder for Database::Abstraction
   17: 
   18: =head1 VERSION
   19: 
   20: Version 0.41
   21: 
   22: =cut
   23: 
   24: our $VERSION = '0.41';
   25: 
   26: =head1 SYNOPSIS
   27: 
   28:     my $db = Database::Foo->new(directory => '/path/to/data');
   29: 
   30:     # --- Basic usage -----------------------------------------------
   31: 
   32:     # All rows
   33:     my $all = $db->query->all();
   34: 
   35:     # Filter, sort, page
   36:     my $rows = $db->query
   37:         ->where(status => 'active')
   38:         ->where(score  => { '>=' => 80 })
   39:         ->order_by('score DESC')
   40:         ->limit(10)
   41:         ->offset(20)
   42:         ->all();
   43: 
   44:     # Single row
   45:     my $row = $db->query->where(name => 'Alice')->first();
   46: 
   47:     # Count
   48:     my $n = $db->query->where(status => 'active')->count();
   49: 
   50:     # --- Specific columns ------------------------------------------
   51: 
   52:     my $names = $db->query->select('name, score')->where(status => 'active')->all();
   53: 
   54:     # --- Joins -----------------------------------------------------
   55: 
   56:     my $joined = $db->query
   57:         ->join({ table => 'dept', on => 'e.dept_id = dept.id', type => 'LEFT' })
   58:         ->where(dept_name => 'Engineering')
   59:         ->all();
   60: 
   61:     # --- OR criteria -----------------------------------------------
   62: 
   63:     my $either = $db->query
   64:         ->where(-or => [
   65:             { status => 'active'           },
   66:             { score  => { '>=' => 95 }     },
   67:         ])
   68:         ->all();
   69: 
   70: =head1 DESCRIPTION
   71: 
   72: C<Database::Abstraction::Query> is a fluent query builder returned by
   73: C<< $db->query() >>.  You assemble a query by chaining builder methods,
   74: then execute it with a terminal method.
   75: 
   76: =over 4
   77: 
   78: =item *
   79: 
   80: B<Builder methods> (C<select>, C<where>, C<join>, C<order_by>, C<limit>,
   81: C<offset>) all return C<$self>, so calls can be chained in any order.
   82: 
   83: =item *
   84: 
   85: B<Terminal methods> (C<all>, C<first>, C<count>) assemble the SQL, execute
   86: it, and return the result.  Each terminal method can be called on the same
   87: builder object independently - calling C<first()> does not modify the stored
   88: state (it temporarily sets LIMIT 1 internally).
   89: 
   90: =item *
   91: 
   92: C<where()> calls are B<merged with AND semantics>: each call adds more
   93: required conditions.  To express OR conditions pass C<< -or => [...] >> as a
   94: key inside a single C<where()> call.
   95: 
   96: =item *
   97: 
   98: The C<join> parameter accepts the same spec as the C<join> parameter in
   99: L<Database::Abstraction/QUERY CRITERIA>.
  100: 
  101: =item *
  102: 
  103: BerkeleyDB backends support C<all()>, C<first()>, and C<count()> with
  104: C<where()> criteria and C<order_by()>/C<limit()>/C<offset()> applied in Perl.
  105: The C<join()> builder method and the C<select()> column projection are not
  106: supported on BerkeleyDB and will raise an error.
  107: 
  108: =back
  109: 
  110: =head1 METHODS
  111: 
  112: =cut
  113: 
  114: =head2 new
  115: 
  116:     my $q = Database::Abstraction::Query->new(_db => $db_object);
  117: 
  118: Construct a new, empty query builder bound to C<$db_object>.  In practice
  119: you almost always call this via C<< $db->query() >> instead.
  120: 
  121: =cut
  122: 
  123: sub new
  124: {
  125: 	my ($class, %args) = @_;
  126: 
  127: 	my $db = $args{'_db'}
  128: 		or croak('Database::Abstraction::Query: _db is required');
  129: 
  130: 	croak('Database::Abstraction::Query: _db must be a Database::Abstraction object')
  131: 		unless blessed($db) && $db->isa('Database::Abstraction');
  132: 
  133: 	return bless {

  Mutants (Total: 2, Killed: 2, Survived: 0)
  134: 		_db       => $db,
  135: 		_select   => '*',
  136: 		_where    => {},
  137: 		_joins    => [],
  138: 		_order_by => undef,
  139: 		_limit    => undef,
  140: 		_offset   => undef,
  141: 	}, $class;
  142: }
  143: 
  144: =head2 select
  145: 
  146:     $q->select('name, score');
  147:     $q->select('COUNT(*) AS n, status');
  148: 
  149: Set the column expression for the C<SELECT> clause.  Default is C<*> (all
  150: columns).  Returns C<$self>.
  151: 
  152: =cut
  153: 
  154: sub select
  155: {
  156: 	my ($self, $cols) = @_;
  157: 	$self->{'_select'} = defined($cols) ? $cols : '*';
  158: 	return $self;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  159: }
  160: 
  161: =head2 where
  162: 
  163:     $q->where(status => 'active');
  164:     $q->where(score  => { '>'  => 8     });
  165:     $q->where(name   => { -in  => [...] });
  166:     $q->where(-or    => [ {...}, {...}     ]);
  167: 
  168: Add one or more criteria to the query.  Multiple calls are merged with
  169: AND semantics.  Accepts a flat list of key/value pairs or a single hashref.
  170: 
  171: Supports the full criteria syntax of L<Database::Abstraction/QUERY CRITERIA>:
  172: plain scalars, wildcard strings, C<undef> (IS NULL), comparison operator
  173: hashrefs (C<< { '>' => n } >>), C<-in>, C<-not_in>, C<-between>,
  174: C<-like>, C<-not_like>, C<-or>, and C<-and>.
  175: 
  176: Returns C<$self>.
  177: 
  178: =cut
  179: 
  180: sub where
  181: {
●182 → 184 → 187  182: 	my $self = shift;
  183: 	my %criteria = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_;
  184: 	for my $k (keys %criteria) {
  185: 		$self->{'_where'}{$k} = $criteria{$k};
  186: 	}
  187: 	return $self;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  188: }
  189: 
  190: =head2 join
  191: 
  192:     $q->join({ table => 'dept', on => 'e.dept_id = dept.id', type => 'LEFT' });
  193: 
  194:     # Multiple joins at once
  195:     $q->join([
  196:         { table => 'dept',    on => 'e.dept_id    = dept.id'    },
  197:         { table => 'country', on => 'e.country_id = country.id' },
  198:     ]);
  199: 
  200: Append one or more JOIN specs.  Each spec is a hashref with:
  201: 
  202: =over 4
  203: 
  204: =item * C<table> - the table to join (required)
  205: 
  206: =item * C<on> - the join condition, verbatim SQL (required)
  207: 
  208: =item * C<type> - join type: C<INNER> (default), C<LEFT>, C<RIGHT>, C<FULL>, C<CROSS>
  209: 
  210: =back
  211: 
  212: Multiple calls accumulate joins.  Returns C<$self>.
  213: 
  214: =cut
  215: 
  216: sub join	## no critic(ProhibitBuiltinHomonyms)
  217: {
  218: 	my ($self, $spec) = @_;
  219: 	my @specs = ref($spec) eq 'ARRAY' ? @{$spec} : ($spec);
  220: 	push @{$self->{'_joins'}}, @specs;
  221: 	return $self;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  222: }
  223: 
  224: =head2 order_by
  225: 
  226:     $q->order_by('name DESC');
  227:     $q->order_by('score DESC, name ASC');
  228: 
  229: Set the C<ORDER BY> expression.  Replaces any previously set ordering.
  230: Returns C<$self>.
  231: 
  232: =cut
  233: 
  234: sub order_by
  235: {
●236 → 241 → 247  236: 	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: 	if(defined $col) {

  Mutants (Total: 1, Killed: 1, Survived: 0)
  242: 		# Block the three primary SQL injection vectors that can appear inside
  243: 		# an ORDER BY expression.  Use m{} to avoid escaping '/' and '\*'.
  244: 		croak("order_by: unsafe ORDER BY expression '$col'")
  245: 			if $col =~ m{; | -- | /\*}x;
  246: 	}

  Mutants (Total: 2, Killed: 2, Survived: 0)
  247: 	$self->{'_order_by'} = $col;
  248: 	return $self;
  249: }
  250: 
  251: =head2 limit
  252: 
  253:     $q->limit(20);
  254: 
  255: Set the maximum number of rows to return.  Returns C<$self>.
  256: 
  257: =cut
  258: 
  259: sub limit
  260: {
  261: 	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: 	croak("limit: value must be a non-negative integer")
  266: 		if !defined($n) || $n !~ /\A\d+\z/;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  267: 	$self->{'_limit'} = int($n);
  268: 	return $self;
  269: }
  270: 
  271: =head2 offset
  272: 
  273:     $q->offset(40);
  274: 
  275: Skip the first N rows (for pagination with L</limit>).  Returns C<$self>.
  276: 
  277: =cut
  278: 
  279: sub offset
  280: {
  281: 	my ($self, $n) = @_;
  282: 	# Same guard as limit(): OFFSET is interpolated directly into SQL.
  283: 	croak("offset: value must be a non-negative integer")
  284: 		if !defined($n) || $n !~ /\A\d+\z/;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  285: 	$self->{'_offset'} = int($n);
  286: 	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 → 296 → 310  294: 	my ($rows, $order_by, $offset, $limit) = @_;

  Mutants (Total: 1, Killed: 1, Survived: 0)
  295: 
  296: 	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: 		my ($col, $dir) = ($order_by =~ /\A(\S+)(?:\s+(ASC|DESC))?\z/i);
  302: 		$dir //= 'ASC';
  303: 		my $desc = ($dir eq 'DESC');	# evaluated once, not on every comparison
  304: 		@{$rows} = sort {
  305: 			$desc
  306: 				? (($b->{$col} // '') cmp ($a->{$col} // ''))
  307: 				: (($a->{$col} // '') cmp ($b->{$col} // ''))
  308: 		} @{$rows};
  309: 	}
  310: 	splice(@{$rows}, 0, $offset) if $offset;
  311: 	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 → 329 → 333  317: 	my ($self, $count_only) = @_;
  318: 
  319: 	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: 	$db->_open_table({});
  324: 	my $table = $db->{'_table_name'};
  325: 
  326: 	my $select = $count_only ? 'COUNT(*)' : $self->{'_select'};
  327: 	my $query  = "SELECT $select FROM $table";

  Mutants (Total: 1, Killed: 1, Survived: 0)
  328: 
  329: 	if(@{$self->{'_joins'}}) {
  330: 		$query .= ' ' . $db->_build_joins($self->{'_joins'});
  331: 	}
  332: 
●333 → 336 → 346  333: 	my ($where, $wargs) = $db->_build_where($self->{'_where'});
  334: 	my @args = @{$wargs};

  Mutants (Total: 1, Killed: 1, Survived: 0)
  335: 
  336: 	if(@{$self->{'_joins'}}) {
  337: 		$query .= " WHERE $where" if $where;
  338: 	} elsif(($db->{'type'} eq 'CSV') && !$db->{'no_entry'}) {
  339: 		my $id = $db->{'id'};
  340: 		$query .= " WHERE $id IS NOT NULL AND $id NOT LIKE '#%'";
  341: 		$query .= " AND ($where)" if $where;
  342: 	} else {
  343: 		$query .= " WHERE $where" if $where;
  344: 	}

  Mutants (Total: 1, Killed: 1, Survived: 0)
  345: 
●346 → 346 → 352  346: 	unless($count_only) {
  347: 		$query .= " ORDER BY $self->{'_order_by'}" if defined $self->{'_order_by'};
  348: 		$query .= " LIMIT $self->{'_limit'}"       if defined $self->{'_limit'};
  349: 		$query .= " OFFSET $self->{'_offset'}"     if defined $self->{'_offset'};
  350: 	}
  351: 
  352: 	return ($query, \@args, $table);
  353: }
  354: 
  355: =head2 all
  356: 
  357:     my $rows = $q->all();
  358: 
  359: B<Terminal method.>  Executes the assembled query and returns an array
  360: reference of hash references, one per matching row.  Returns an empty
  361: array reference when there are no matches (never C<undef>).
  362: 
  363: =cut
  364: 
  365: sub all
  366: {
●367 → 373 → 382  367: 	my $self = shift;
  368: 	my $db   = $self->{'_db'};
  369: 
  370: 	# Ensure _open() fires before checking the backend type.
  371: 	$db->_open_table({});

  Mutants (Total: 1, Killed: 1, Survived: 0)
  372: 
  373: 	if($db->{'berkeley'} || ($db->{'type'} // '') eq 'Deep') {
  374: 		my $backend = $db->{'berkeley'} ? 'BerkeleyDB' : 'Deep';
  375: 		croak(ref($db), ": query->all() with JOINs is not supported on $backend")
  376: 			if @{$self->{'_joins'}};
  377: 		my $rows = $db->selectall_arrayref({%{$self->{'_where'}}});

  Mutants (Total: 2, Killed: 2, Survived: 0)
  378: 		_apply_perl_sort_limit($rows, $self->{'_order_by'}, $self->{'_offset'}, $self->{'_limit'});
  379: 		return $rows;
  380: 	}
  381: 
●382 → 389 → 392  382: 	my ($query, $args, $table) = $self->_build_sql(0);
  383: 	$db->_debug("Query->all: $query");
  384: 
  385: 	my $sth = $db->{$table}->prepare_cached($query);
  386: 	$sth->execute(@{$args}) or croak("$query: @{$args}");
  387: 
  388: 	my @rows;
  389: 	while(my $row = $sth->fetchrow_hashref()) {
  390: 		push @rows, $row;

  Mutants (Total: 2, Killed: 2, Survived: 0)
  391: 	}
  392: 	return \@rows;
  393: }
  394: 
  395: =head2 first
  396: 
  397:     my $row = $q->first();    # \%hashref or undef
  398: 
  399: B<Terminal method.>  Executes the query with C<LIMIT 1> and returns the
  400: first matching row as a hash reference, or C<undef> when there is no match.
  401: Any C<limit()> or C<offset()> you have set is temporarily overridden for
  402: efficiency (only the LIMIT is overridden; offset is still applied).
  403: 
  404: =cut
  405: 
  406: sub first
  407: {
●408 → 413 → 425  408: 	my $self = shift;
  409: 	my $db   = $self->{'_db'};
  410: 
  411: 	$db->_open_table({});

  Mutants (Total: 1, Killed: 1, Survived: 0)
  412: 
  413: 	if($db->{'berkeley'} || ($db->{'type'} // '') eq 'Deep') {
  414: 		my $backend = $db->{'berkeley'} ? 'BerkeleyDB' : 'Deep';
  415: 		croak(ref($db), ": query->first() with JOINs is not supported on $backend")
  416: 			if @{$self->{'_joins'}};
  417: 		my $rows = $db->selectall_arrayref({%{$self->{'_where'}}});

  Mutants (Total: 2, Killed: 2, Survived: 0)
  418: 		_apply_perl_sort_limit($rows, $self->{'_order_by'}, $self->{'_offset'}, undef);
  419: 		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: 	local $self->{'_limit'} = 1;
  426: 	my ($query, $args, $table) = $self->_build_sql(0);
  427: 
  428: 	$db->_debug("Query->first: $query");
  429: 
  430: 	my $sth = $db->{$table}->prepare_cached($query);
  431: 	$sth->execute(@{$args}) or croak("$query: @{$args}");
  432: 

  Mutants (Total: 2, Killed: 2, Survived: 0)
  433: 	my $row = $sth->fetchrow_hashref();
  434: 	$sth->finish();
  435: 	return $row;
  436: }
  437: 
  438: =head2 count
  439: 
  440:     my $n = $q->count();
  441: 
  442: B<Terminal method.>  Executes C<SELECT COUNT(*)> with the current C<WHERE>
  443: and C<JOIN> clauses and returns the integer count.  C<ORDER BY>, C<LIMIT>,
  444: and C<OFFSET> are ignored for the count query.
  445: 
  446: =cut
  447: 
  448: sub count
  449: {
●450 → 455 → 462  450: 	my $self = shift;
  451: 	my $db   = $self->{'_db'};
  452: 

  Mutants (Total: 1, Killed: 1, Survived: 0)
  453: 	$db->_open_table({});
  454: 
  455: 	if($db->{'berkeley'} || ($db->{'type'} // '') eq 'Deep') {
  456: 		my $backend = $db->{'berkeley'} ? 'BerkeleyDB' : 'Deep';

  Mutants (Total: 2, Killed: 2, Survived: 0)
  457: 		croak(ref($db), ": query->count() with JOINs is not supported on $backend")
  458: 			if @{$self->{'_joins'}};
  459: 		return $db->count({%{$self->{'_where'}}});
  460: 	}
  461: 
  462: 	my ($query, $args, $table) = $self->_build_sql(1);
  463: 	$db->_debug("Query->count: $query");
  464: 
  465: 	my $sth = $db->{$table}->prepare_cached($query);
  466: 	$sth->execute(@{$args}) or croak("$query: @{$args}");
  467: 

  Mutants (Total: 2, Killed: 2, Survived: 0)
  468: 	my $row = $sth->fetchrow_arrayref();
  469: 	$sth->finish();
  470: 	return $row ? $row->[0] : 0;
  471: }
  472: 
  473: =head1 SEE ALSO
  474: 
  475: L<Database::Abstraction> - the parent module and its L<Database::Abstraction/QUERY CRITERIA> section.
  476: 
  477: =head1 AUTHOR
  478: 
  479: Nigel Horne, C<< <njh at nigelhorne.com> >>
  480: 
  481: =head1 SUPPORT
  482: 
  483: Please report bugs at
  484: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Database-Abstraction>.
  485: 
  486: =head1 LICENSE AND COPYRIGHT
  487: 
  488: Copyright 2026 Nigel Horne.
  489: 
  490: Usage is subject to the GPL2 licence terms.
  491: If you use it,
  492: please let me know.
  493: 
  494: =cut
  495: 
  496: 1;