lib/Database/Abstraction/Query.pm

        start → end → jump
        

    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: 
   10: use Carp;
   11: use Scalar::Util qw(blessed);
   12: 
   13: =head1 NAME
   14: 
   15: Database::Abstraction::Query - Fluent, chainable query builder for Database::Abstraction
   16: 
   17: =head1 VERSION
   18: 
   19: Version 0.36
   20: 
   21: =cut
   22: 
   23: our $VERSION = '0.36';
   24: 
   25: =head1 SYNOPSIS
   26: 
   27:     my $db = Database::Foo->new(directory => '/path/to/data');
   28: 
   29:     # --- Basic usage -----------------------------------------------
   30: 
   31:     # All rows
   32:     my $all = $db->query->all();
   33: 
   34:     # Filter, sort, page
   35:     my $rows = $db->query
   36:         ->where(status => 'active')
   37:         ->where(score  => { '>=' => 80 })
   38:         ->order_by('score DESC')
   39:         ->limit(10)
   40:         ->offset(20)
   41:         ->all();
   42: 
   43:     # Single row
   44:     my $row = $db->query->where(name => 'Alice')->first();
   45: 
   46:     # Count
   47:     my $n = $db->query->where(status => 'active')->count();
   48: 
   49:     # --- Specific columns ------------------------------------------
   50: 
   51:     my $names = $db->query->select('name, score')->where(status => 'active')->all();
   52: 
   53:     # --- Joins -----------------------------------------------------
   54: 
   55:     my $joined = $db->query
   56:         ->join({ table => 'dept', on => 'e.dept_id = dept.id', type => 'LEFT' })
   57:         ->where(dept_name => 'Engineering')
   58:         ->all();
   59: 
   60:     # --- OR criteria -----------------------------------------------
   61: 
   62:     my $either = $db->query
   63:         ->where(-or => [
   64:             { status => 'active'           },
   65:             { score  => { '>=' => 95 }     },
   66:         ])
   67:         ->all();
   68: 
   69: =head1 DESCRIPTION
   70: 
   71: C<Database::Abstraction::Query> is a fluent query builder returned by
   72: C<< $db->query() >>.  You assemble a query by chaining builder methods,
   73: then execute it with a terminal method.
   74: 
   75: =over 4
   76: 
   77: =item *
   78: 
   79: B<Builder methods> (C<select>, C<where>, C<join>, C<order_by>, C<limit>,
   80: C<offset>) all return C<$self>, so calls can be chained in any order.
   81: 
   82: =item *
   83: 
   84: B<Terminal methods> (C<all>, C<first>, C<count>) assemble the SQL, execute
   85: it, and return the result.  Each terminal method can be called on the same
   86: builder object independently - calling C<first()> does not modify the stored
   87: state (it temporarily sets LIMIT 1 internally).
   88: 
   89: =item *
   90: 
   91: C<where()> calls are B<merged with AND semantics>: each call adds more
   92: required conditions.  To express OR conditions pass C<< -or => [...] >> as a
   93: key inside a single C<where()> call.
   94: 
   95: =item *
   96: 
   97: The C<join> parameter accepts the same spec as the C<join> parameter in
   98: L<Database::Abstraction/QUERY CRITERIA>.
   99: 
  100: =item *
  101: 
  102: BerkeleyDB backends support C<all()>, C<first()>, and C<count()> with
  103: C<where()> criteria and C<order_by()>/C<limit()>/C<offset()> applied in Perl.
  104: The C<join()> builder method and the C<select()> column projection are not
  105: supported on BerkeleyDB and will raise an error.
  106: 
  107: =back
  108: 
  109: =head1 METHODS
  110: 
  111: =cut
  112: 
  113: =head2 new
  114: 
  115:     my $q = Database::Abstraction::Query->new(_db => $db_object);
  116: 
  117: Construct a new, empty query builder bound to C<$db_object>.  In practice
  118: you almost always call this via C<< $db->query() >> instead.
  119: 
  120: =cut
  121: 
  122: sub new
  123: {
  124: 	my ($class, %args) = @_;
  125: 
  126: 	my $db = $args{'_db'}
  127: 		or croak('Database::Abstraction::Query: _db is required');
  128: 
  129: 	croak('Database::Abstraction::Query: _db must be a Database::Abstraction object')
  130: 		unless blessed($db) && $db->isa('Database::Abstraction');
  131: 
  132: 	return bless {
  Mutants (Total: 2, Killed: 2, Survived: 0)
  133: 		_db       => $db,
  134: 		_select   => '*',
  135: 		_where    => {},
  136: 		_joins    => [],
  137: 		_order_by => undef,
  138: 		_limit    => undef,
  139: 		_offset   => undef,
  140: 	}, $class;
  141: }
  142: 
  143: =head2 select
  144: 
  145:     $q->select('name, score');
  146:     $q->select('COUNT(*) AS n, status');
  147: 
  148: Set the column expression for the C<SELECT> clause.  Default is C<*> (all
  149: columns).  Returns C<$self>.
  150: 
  151: =cut
  152: 
  153: sub select
  154: {
  155: 	my ($self, $cols) = @_;
  156: 	$self->{'_select'} = defined($cols) ? $cols : '*';
  157: 	return $self;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  158: }
  159: 
  160: =head2 where
  161: 
  162:     $q->where(status => 'active');
  163:     $q->where(score  => { '>'  => 8     });
  164:     $q->where(name   => { -in  => [...] });
  165:     $q->where(-or    => [ {...}, {...}     ]);
  166: 
  167: Add one or more criteria to the query.  Multiple calls are merged with
  168: AND semantics.  Accepts a flat list of key/value pairs or a single hashref.
  169: 
  170: Supports the full criteria syntax of L<Database::Abstraction/QUERY CRITERIA>:
  171: plain scalars, wildcard strings, C<undef> (IS NULL), comparison operator
  172: hashrefs (C<< { '>' => n } >>), C<-in>, C<-not_in>, C<-between>,
  173: C<-like>, C<-not_like>, C<-or>, and C<-and>.
  174: 
  175: Returns C<$self>.
  176: 
  177: =cut
  178: 
  179: sub where
  180: {
●181 → 183 → 186  181: 	my $self = shift;
  182: 	my %criteria = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_;
  183: 	for my $k (keys %criteria) {
  184: 		$self->{'_where'}{$k} = $criteria{$k};
  185: 	}
  186: 	return $self;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  187: }
  188: 
  189: =head2 join
  190: 
  191:     $q->join({ table => 'dept', on => 'e.dept_id = dept.id', type => 'LEFT' });
  192: 
  193:     # Multiple joins at once
  194:     $q->join([
  195:         { table => 'dept',    on => 'e.dept_id    = dept.id'    },
  196:         { table => 'country', on => 'e.country_id = country.id' },
  197:     ]);
  198: 
  199: Append one or more JOIN specs.  Each spec is a hashref with:
  200: 
  201: =over 4
  202: 
  203: =item * C<table> - the table to join (required)
  204: 
  205: =item * C<on> - the join condition, verbatim SQL (required)
  206: 
  207: =item * C<type> - join type: C<INNER> (default), C<LEFT>, C<RIGHT>, C<FULL>, C<CROSS>
  208: 
  209: =back
  210: 
  211: Multiple calls accumulate joins.  Returns C<$self>.
  212: 
  213: =cut
  214: 
  215: sub join	## no critic(ProhibitBuiltinHomonyms)
  216: {
  217: 	my ($self, $spec) = @_;
  218: 	my @specs = ref($spec) eq 'ARRAY' ? @{$spec} : ($spec);
  219: 	push @{$self->{'_joins'}}, @specs;
  220: 	return $self;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  221: }
  222: 
  223: =head2 order_by
  224: 
  225:     $q->order_by('name DESC');
  226:     $q->order_by('score DESC, name ASC');
  227: 
  228: Set the C<ORDER BY> expression.  Replaces any previously set ordering.
  229: Returns C<$self>.
  230: 
  231: =cut
  232: 
  233: sub order_by
  234: {
  235: 	my ($self, $col) = @_;
  236: 	$self->{'_order_by'} = $col;
  237: 	return $self;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  238: }
  239: 
  240: =head2 limit
  241: 
  242:     $q->limit(20);
  243: 
  244: Set the maximum number of rows to return.  Returns C<$self>.
  245: 
  246: =cut
  247: 
  248: sub limit
  249: {
  250: 	my ($self, $n) = @_;
  251: 	$self->{'_limit'} = $n;
  252: 	return $self;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  253: }
  254: 
  255: =head2 offset
  256: 
  257:     $q->offset(40);
  258: 
  259: Skip the first N rows (for pagination with L</limit>).  Returns C<$self>.
  260: 
  261: =cut
  262: 
  263: sub offset
  264: {
  265: 	my ($self, $n) = @_;
  266: 	$self->{'_offset'} = $n;
  267: 	return $self;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  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).
  273: sub _apply_perl_sort_limit
  274: {
●[NOT COVERED] 275 → 277 → 286  275: 	my ($rows, $order_by, $offset, $limit) = @_;
  276: 
  277: 	if(defined $order_by) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_277_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  278: 		my ($col, $dir) = ($order_by =~ /^(\S+)(?:\s+(ASC|DESC))?$/i);
  279: 		$dir //= 'ASC';
  280: 		@{$rows} = sort {
  281: 			$dir =~ /DESC/i
  282: 				? (($b->{$col} // '') cmp ($a->{$col} // ''))
  283: 				: (($a->{$col} // '') cmp ($b->{$col} // ''))
  284: 		} @{$rows};
  285: 	}
  286: 	splice(@{$rows}, 0, $offset) if $offset;
  287: 	splice(@{$rows}, $limit)     if defined $limit;
  288: }
  289: 
  290: # Internal: assemble SQL + bind args.  $count_only replaces SELECT cols with COUNT(*).
  291: sub _build_sql
  292: {
●293 → 305 → 309  293: 	my ($self, $count_only) = @_;
  294: 
  295: 	my $db    = $self->{'_db'};
  296: 	my $table = $db->{'table'} || ref($db);
  297: 	$table =~ s/.*:://;
  298: 
  299: 	# Ensure the underlying table connection is open
  300: 	$db->_open_table({});
  301: 
  302: 	my $select = $count_only ? 'COUNT(*)' : $self->{'_select'};
  303: 	my $query  = "SELECT $select FROM $table";
  304: 
  305: 	if(@{$self->{'_joins'}}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  306: 		$query .= ' ' . $db->_build_joins($self->{'_joins'});
  307: 	}
  308: 
●309 → 312 → 322  309: 	my ($where, $wargs) = $db->_build_where($self->{'_where'});
  310: 	my @args = @{$wargs};
  311: 
  312: 	if(@{$self->{'_joins'}}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  313: 		$query .= " WHERE $where" if $where;
  314: 	} elsif(($db->{'type'} eq 'CSV') && !$db->{'no_entry'}) {
  315: 		my $id = $db->{'id'};
  316: 		$query .= " WHERE $id IS NOT NULL AND $id NOT LIKE '#%'";
  317: 		$query .= " AND ($where)" if $where;
  318: 	} else {
  319: 		$query .= " WHERE $where" if $where;
  320: 	}
  321: 
●322 → 322 → 328  322: 	unless($count_only) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  323: 		$query .= " ORDER BY $self->{'_order_by'}" if defined $self->{'_order_by'};
  324: 		$query .= " LIMIT $self->{'_limit'}"       if defined $self->{'_limit'};
  325: 		$query .= " OFFSET $self->{'_offset'}"     if defined $self->{'_offset'};
  326: 	}
  327: 
  328: 	return ($query, \@args, $table);
  329: }
  330: 
  331: =head2 all
  332: 
  333:     my $rows = $q->all();
  334: 
  335: B<Terminal method.>  Executes the assembled query and returns an array
  336: reference of hash references, one per matching row.  Returns an empty
  337: array reference when there are no matches (never C<undef>).
  338: 
  339: =cut
  340: 
  341: sub all
  342: {
●343 → 349 → 357  343: 	my $self = shift;
  344: 	my $db   = $self->{'_db'};
  345: 
  346: 	# Ensure _open() fires before checking the backend type.
  347: 	$db->_open_table({});
  348: 
  349: 	if($db->{'berkeley'}) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  350: 		croak(ref($db), ': query->all() with JOINs is not supported on BerkeleyDB')
  351: 			if @{$self->{'_joins'}};
  352: 		my $rows = $db->selectall_arrayref({%{$self->{'_where'}}});
  353: 		_apply_perl_sort_limit($rows, $self->{'_order_by'}, $self->{'_offset'}, $self->{'_limit'});
  354: 		return $rows;

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
BOOL_NEGATE_354_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_354_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
  355: 	}
  356: 
●357 → 364 → 367  357: 	my ($query, $args, $table) = $self->_build_sql(0);
  358: 	$db->_debug("Query->all: $query");
  359: 
  360: 	my $sth = $db->{$table}->prepare_cached($query);
  361: 	$sth->execute(@{$args}) or croak("$query: @{$args}");
  362: 
  363: 	my @rows;
  364: 	while(my $row = $sth->fetchrow_hashref()) {
  365: 		push @rows, $row;
  366: 	}
  367: 	return \@rows;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  368: }
  369: 
  370: =head2 first
  371: 
  372:     my $row = $q->first();    # \%hashref or undef
  373: 
  374: B<Terminal method.>  Executes the query with C<LIMIT 1> and returns the
  375: first matching row as a hash reference, or C<undef> when there is no match.
  376: Any C<limit()> or C<offset()> you have set is temporarily overridden for
  377: efficiency (only the LIMIT is overridden; offset is still applied).
  378: 
  379: =cut
  380: 
  381: sub first
  382: {
●383 → 388 → 396  383: 	my $self = shift;
  384: 	my $db   = $self->{'_db'};
  385: 
  386: 	$db->_open_table({});
  387: 
  388: 	if($db->{'berkeley'}) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_388_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  389: 		croak(ref($db), ': query->first() with JOINs is not supported on BerkeleyDB')
  390: 			if @{$self->{'_joins'}};
  391: 		my $rows = $db->selectall_arrayref({%{$self->{'_where'}}});
  392: 		_apply_perl_sort_limit($rows, $self->{'_order_by'}, $self->{'_offset'}, undef);
  393: 		return $rows->[0];

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
BOOL_NEGATE_393_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_393_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
  394: 	}
  395: 
  396: 	my $saved = $self->{'_limit'};
  397: 	$self->{'_limit'} = 1;
  398: 	my ($query, $args, $table) = $self->_build_sql(0);
  399: 	$self->{'_limit'} = $saved;
  400: 
  401: 	$db->_debug("Query->first: $query");
  402: 
  403: 	my $sth = $db->{$table}->prepare_cached($query);
  404: 	$sth->execute(@{$args}) or croak("$query: @{$args}");
  405: 
  406: 	my $row = $sth->fetchrow_hashref();
  407: 	$sth->finish();
  408: 	return $row;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  409: }
  410: 
  411: =head2 count
  412: 
  413:     my $n = $q->count();
  414: 
  415: B<Terminal method.>  Executes C<SELECT COUNT(*)> with the current C<WHERE>
  416: and C<JOIN> clauses and returns the integer count.  C<ORDER BY>, C<LIMIT>,
  417: and C<OFFSET> are ignored for the count query.
  418: 
  419: =cut
  420: 
  421: sub count
  422: {
●423 → 428 → 434  423: 	my $self = shift;
  424: 	my $db   = $self->{'_db'};
  425: 
  426: 	$db->_open_table({});
  427: 
  428: 	if($db->{'berkeley'}) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_428_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  429: 		croak(ref($db), ': query->count() with JOINs is not supported on BerkeleyDB')
  430: 			if @{$self->{'_joins'}};
  431: 		return $db->count({%{$self->{'_where'}}});

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
BOOL_NEGATE_431_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_431_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
  432: 	}
  433: 
  434: 	my ($query, $args, $table) = $self->_build_sql(1);
  435: 	$db->_debug("Query->count: $query");
  436: 
  437: 	my $sth = $db->{$table}->prepare_cached($query);
  438: 	$sth->execute(@{$args}) or croak("$query: @{$args}");
  439: 
  440: 	my $row = $sth->fetchrow_arrayref();
  441: 	$sth->finish();
  442: 	return $row ? $row->[0] : 0;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  443: }
  444: 
  445: =head1 SEE ALSO
  446: 
  447: L<Database::Abstraction> - the parent module and its L<Database::Abstraction/QUERY CRITERIA> section.
  448: 
  449: =head1 AUTHOR
  450: 
  451: Nigel Horne, C<< <njh at nigelhorne.com> >>
  452: 
  453: =head1 SUPPORT
  454: 
  455: Please report bugs at
  456: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Database-Abstraction>.
  457: 
  458: =head1 LICENSE AND COPYRIGHT
  459: 
  460: Copyright 2026 Nigel Horne.
  461: 
  462: Usage is subject to the GPL2 licence terms.
  463: 
  464: =cut
  465: 
  466: 1;