TER1 (Statement): 91.38%
TER2 (Branch): 86.07%
TER3 (LCSAJ): 100.0% (16/16)
Approximate LCSAJ segments: 123
● 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.
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: =encoding utf8 15: 16: =head1 NAME 17: 18: Database::Abstraction::Query - Fluent, chainable query builder for Database::Abstraction 19: 20: =head1 VERSION 21: 22: Version 0.51 23: 24: =cut 25: 26: our $VERSION = '0.52'; 27: 28: =head1 SYNOPSIS 29: 30: my $db = Database::Foo->new(directory => '/path/to/data'); 31: 32: # --- Basic usage ----------------------------------------------- 33: 34: # All rows 35: my $all = $db->query->all(); 36: 37: # Filter, sort, page 38: my $rows = $db->query 39: ->where(status => 'active') 40: ->where(score => { '>=' => 80 }) 41: ->order_by('score DESC') 42: ->limit(10) 43: ->offset(20) 44: ->all(); 45: 46: # Single row 47: my $row = $db->query->where(name => 'Alice')->first(); 48: 49: # Count 50: my $n = $db->query->where(status => 'active')->count(); 51: 52: # --- Specific columns ------------------------------------------ 53: 54: my $names = $db->query->select('name, score')->where(status => 'active')->all(); 55: 56: # --- Joins ----------------------------------------------------- 57: 58: my $joined = $db->query 59: ->join({ table => 'dept', on => 'e.dept_id = dept.id', type => 'LEFT' }) 60: ->where(dept_name => 'Engineering') 61: ->all(); 62: 63: # --- OR criteria ----------------------------------------------- 64: 65: my $either = $db->query 66: ->where(-or => [ 67: { status => 'active' }, 68: { score => { '>=' => 95 } }, 69: ]) 70: ->all(); 71: 72: =head1 DESCRIPTION 73: 74: C<Database::Abstraction::Query> is a fluent query builder returned by 75: C<< $db->query() >>. You assemble a query by chaining builder methods, 76: then execute it with a terminal method. 77: 78: =over 4 79: 80: =item * 81: 82: B<Builder methods> (C<select>, C<where>, C<join>, C<order_by>, C<limit>, 83: C<offset>, C<group_by>, C<measure>, C<having>) all return C<$self>, so 84: calls can be chained in any order. 85: 86: =item * 87: 88: B<Terminal methods> (C<all>, C<first>, C<count>) assemble the SQL, execute 89: it, and return the result. Each terminal method can be called on the same 90: builder object independently - calling C<first()> does not modify the stored 91: state (it temporarily sets LIMIT 1 internally). 92: 93: =item * 94: 95: C<where()> calls are B<merged with AND semantics>: each call adds more 96: required conditions. To express OR conditions pass C<< -or => [...] >> as a 97: key inside a single C<where()> call. 98: 99: =item * 100: 101: The C<join> parameter accepts the same spec as the C<join> parameter in 102: L<Database::Abstraction/QUERY CRITERIA>. 103: 104: =item * 105: 106: BerkeleyDB backends support C<all()>, C<first()>, and C<count()> with 107: C<where()> criteria and C<order_by()>/C<limit()>/C<offset()> applied in Perl. 108: The C<join()> builder method and the C<select()> column projection are not 109: supported on BerkeleyDB and will raise an error. 110: 111: =back 112: 113: =head1 METHODS 114: 115: =cut 116: 117: =head2 new 118: 119: my $q = Database::Abstraction::Query->new(_db => $db_object); 120: 121: Construct a new, empty query builder bound to C<$db_object>. In practice 122: you almost always call this via C<< $db->query() >> instead. 123: 124: =cut 125: 126: sub new 127: { 128: my ($class, %args) = @_; 129: 130: my $db = $args{'_db'} 131: or croak('Database::Abstraction::Query: _db is required'); 132: 133: croak('Database::Abstraction::Query: _db must be a Database::Abstraction object')Mutants (Total: 2, Killed: 2, Survived: 0)
134: unless blessed($db) && $db->isa('Database::Abstraction'); 135: 136: return bless { 137: _db => $db, 138: _select => '*', 139: _where => {}, 140: _joins => [], 141: _order_by => undef, 142: _limit => undef, 143: _offset => undef, 144: _group_by => [], 145: _measures => [], 146: _having => {}, 147: }, $class; 148: } 149: 150: =head2 select 151: 152: $q->select('name, score'); 153: $q->select('COUNT(*) AS n, status'); 154: 155: Set the column expression for the C<SELECT> clause. Default is C<*> (all 156: columns). Returns C<$self>. 157: 158: =cut
Mutants (Total: 2, Killed: 2, Survived: 0)
159: 160: sub select 161: { 162: my ($self, $cols) = @_; 163: $self->{'_select'} = defined($cols) ? $cols : '*'; 164: return $self; 165: } 166: 167: =head2 where 168: 169: $q->where(status => 'active'); 170: $q->where(score => { '>' => 8 }); 171: $q->where(name => { -in => [...] }); 172: $q->where(-or => [ {...}, {...} ]); 173: 174: Add one or more criteria to the query. Multiple calls are merged with 175: AND semantics. Accepts a flat list of key/value pairs or a single hashref. 176: 177: Supports the full criteria syntax of L<Database::Abstraction/QUERY CRITERIA>: 178: plain scalars, wildcard strings, C<undef> (IS NULL), comparison operator 179: hashrefs (C<< { '>' => n } >>), C<-in>, C<-not_in>, C<-between>, 180: C<-like>, C<-not_like>, C<-or>, and C<-and>. 181: 182: Returns C<$self>. 183: 184: =cut 185: 186: sub where 187: {
Mutants (Total: 2, Killed: 2, Survived: 0)
●188 → 190 → 193 188: my $self = shift; 189: my %criteria = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_; 190: for my $k (keys %criteria) { 191: $self->{'_where'}{$k} = $criteria{$k}; 192: } 193: return $self; 194: } 195: 196: =head2 join 197: 198: $q->join({ table => 'dept', on => 'e.dept_id = dept.id', type => 'LEFT' }); 199: 200: # Multiple joins at once 201: $q->join([ 202: { table => 'dept', on => 'e.dept_id = dept.id' }, 203: { table => 'country', on => 'e.country_id = country.id' }, 204: ]); 205: 206: Append one or more JOIN specs. Each spec is a hashref with: 207: 208: =over 4 209: 210: =item * C<table> - the table to join (required) 211: 212: =item * C<on> - the join condition, verbatim SQL (required) 213: 214: =item * C<type> - join type: C<INNER> (default), C<LEFT>, C<RIGHT>, C<FULL>, C<CROSS> 215: 216: =back 217: 218: Multiple calls accumulate joins. Returns C<$self>. 219: 220: =cut 221:
Mutants (Total: 2, Killed: 2, Survived: 0)
222: sub join ## no critic(ProhibitBuiltinHomonyms) 223: { 224: my ($self, $spec) = @_; 225: my @specs = ref($spec) eq 'ARRAY' ? @{$spec} : ($spec); 226: push @{$self->{'_joins'}}, @specs; 227: return $self; 228: } 229: 230: =head2 order_by 231: 232: $q->order_by('name DESC'); 233: $q->order_by('score DESC, name ASC'); 234: 235: Set the C<ORDER BY> expression. Replaces any previously set ordering. 236: Returns C<$self>. 237: 238: =cut 239: 240: sub order_by 241: {
Mutants (Total: 1, Killed: 1, Survived: 0)
●242 → 247 → 253 242: my ($self, $col) = @_; 243: # Guard the three primary SQL injection vectors before the value is 244: # interpolated verbatim into ORDER BY $col (see _build_sql). The check 245: # is deliberately permissive so it does not break legitimate multi-column 246: # expressions ("score DESC, name ASC") or SQL functions ("ABS(score) DESC"). 247: if(defined $col) { 248: # Block the three primary SQL injection vectors that can appear inside
Mutants (Total: 2, Killed: 2, Survived: 0)
249: # an ORDER BY expression. Use m{} to avoid escaping '/' and '\*'. 250: croak("order_by: unsafe ORDER BY expression '$col'") 251: if $col =~ m{; | -- | /\*}x; 252: } 253: $self->{'_order_by'} = $col; 254: return $self; 255: } 256: 257: =head2 limit 258: 259: $q->limit(20); 260: 261: Set the maximum number of rows to return. Returns C<$self>. 262: 263: =cut 264: 265: sub limit 266: { 267: my ($self, $n) = @_; 268: # Validate at the setter: LIMIT must be a non-negative integer.
Mutants (Total: 2, Killed: 2, Survived: 0)
269: # Direct interpolation into SQL (line: LIMIT $n) makes any non-integer a 270: # potential injection vector (e.g. "10; DROP TABLE users"). 271: croak("limit: value must be a non-negative integer") 272: if !defined($n) || $n !~ /\A\d+\z/; 273: $self->{'_limit'} = int($n); 274: return $self; 275: } 276: 277: =head2 offset 278: 279: $q->offset(40); 280: 281: Skip the first N rows (for pagination with L</limit>). Returns C<$self>. 282: 283: =cut 284: 285: sub offset 286: {
Mutants (Total: 2, Killed: 2, Survived: 0)
287: my ($self, $n) = @_; 288: # Same guard as limit(): OFFSET is interpolated directly into SQL. 289: croak("offset: value must be a non-negative integer") 290: if !defined($n) || $n !~ /\A\d+\z/; 291: $self->{'_offset'} = int($n); 292: return $self; 293: } 294: 295: =head2 group_by 296:
Mutants (Total: 1, Killed: 1, Survived: 0)
297: $q->group_by('region', 'month'); 298: $q->group_by(\@cols); 299: $q->group_by([]); # clear (grand total) 300: 301: Set the C<GROUP BY> columns for an aggregate query. Replaces any previously 302: set list. Has no effect unless at least one C<measure()> call follows. 303: Returns C<$self>. 304: 305: =head3 API SPECIFICATION 306: 307: =head4 Arguments 308: 309: @cols # one or more column name strings (replaces any previous group_by) 310: 311: =head4 Returns 312: 313: $self (the same Query object, for chaining) 314: 315: =cut 316: 317: sub group_by 318: { 319: my $self = shift; 320: my @cols = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_; 321: $self->{'_group_by'} = \@cols; 322: return $self; 323: } 324: 325: =head2 measure 326: 327: $q->measure('amount', 'sum', 'revenue'); 328: $q->measure(undef, 'count', 'orders'); # COUNT(*) 329: $q->measure({ col => 'c', fn => 'avg', as => 'mean' }); 330: 331: Append a measure to the aggregate query. May be called multiple times; 332: measures accumulate. Accepts either three positional arguments 333: (C<col>, C<fn>, C<as>) or a single hashref with those keys. 334: 335: C<fn> must be one of C<sum>, C<avg>, C<min>, C<max>, C<count>, 336: C<count_distinct>. C<col> is optional only for C<count> (COUNT(*)). 337:
Mutants (Total: 1, Killed: 1, Survived: 0)
338: Returns C<$self>. 339: 340: =head3 API SPECIFICATION 341: 342: =head4 Arguments 343: 344: $col # Str | undef -- column to aggregate; omit/undef for COUNT(*) 345: $fn # Str -- one of: sum avg min max count count_distinct 346: $as # Str -- result key alias (required; valid SQL identifier) 347:
Mutants (Total: 1, Killed: 1, Survived: 0)
348: =head4 Returns 349: 350: $self (the same Query object, for chaining) 351: 352: Calls to C<measure()> accumulate: each call appends one measure to 353: the list. To start over, create a new query builder with 354: C<< $db->query() >>. 355: 356: =cut 357:
Mutants (Total: 1, Killed: 1, Survived: 0)
358: sub measure 359: { 360: my ($self, $col_or_spec, $fn, $as) = @_; 361: my $spec = ref($col_or_spec) eq 'HASH' 362: ? $col_or_spec 363: : { col => $col_or_spec, fn => $fn, as => $as }; 364: push @{$self->{'_measures'}}, $spec; 365: return $self; 366: } 367: 368: =head2 having 369: 370: $q->having(revenue => { '>' => 1000 }); 371: $q->having(\%criteria); 372: 373: Add post-aggregation filter criteria. Multiple calls are merged with AND 374: semantics, exactly like C<where()>. Keys must be C<by> column names or 375: measure aliases (validated by C<aggregate()>). 376: 377: Returns C<$self>. 378: 379: =head3 API SPECIFICATION 380: 381: =head4 Arguments 382: 383: %criteria # key-value pairs where each key is a by-column name or 384: # a measure alias, and each value is a scalar or an
Mutants (Total: 1, Killed: 1, Survived: 0)
385: # operator hashref (same syntax as selectall_arrayref) 386: 387: =head4 Returns 388: 389: $self (the same Query object, for chaining) 390:
Mutants (Total: 2, Killed: 2, Survived: 0)
391: Multiple calls to C<having()> are merged with AND semantics, exactly 392: like multiple calls to C<where()>. 393: 394: =cut 395: 396: sub having 397: { ●398 → 400 → 403 398: my $self = shift; 399: my %criteria = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_; 400: for my $k (keys %criteria) { 401: $self->{'_having'}{$k} = $criteria{$k}; 402: } 403: return $self;
Mutants (Total: 2, Killed: 2, Survived: 0)
404: } 405: 406: # Apply Perl-side sort, offset, and limit to an arrayref of rows in place. 407: # Used by the BerkeleyDB execution paths in all() and first(). 408: # order_by must be a single "column [ASC|DESC]" string (multi-column not supported). 409: sub _apply_perl_sort_limit 410: { ●411 → 413 → 435 411: my ($rows, $order_by, $offset, $limit) = @_; 412: 413: if(defined $order_by) { 414: # Use \z (true end-of-string) not $ (matches before a trailing newline). 415: # (ASC|DESC) is already a non-regex check after capture; $dir is either 416: # 'ASC', 'DESC', or undef — hoist the direction decision out of the sort 417: # comparator so it is not evaluated O(N log N) times for an N-row result. 418: my ($col, $dir) = ($order_by =~ / 419: \A 420: (\S+) # column expression (non-whitespace) 421: (?: 422: \s+ # whitespace separator 423: (ASC|DESC) # sort direction keyword 424: )?
Mutants (Total: 1, Killed: 1, Survived: 0)
425: \z 426: /xi); 427: $dir //= 'ASC'; 428: my $desc = ($dir eq 'DESC'); # evaluated once, not on every comparison 429: @{$rows} = sort { 430: $desc
Mutants (Total: 2, Killed: 2, Survived: 0)
431: ? (($b->{$col} // '') cmp ($a->{$col} // '')) 432: : (($a->{$col} // '') cmp ($b->{$col} // '')) 433: } @{$rows}; 434: } 435: splice(@{$rows}, 0, $offset) if $offset; 436: splice(@{$rows}, $limit) if defined $limit; 437: } 438: 439: # Internal: assemble SQL + bind args. $count_only replaces SELECT cols with COUNT(*). 440: sub _build_sql 441: { ●442 → 454 → 458 442: my ($self, $count_only) = @_; 443: 444: my $db = $self->{'_db'}; 445: 446: # _open_table populates $db->{'_table_name'} as a side-effect, so call it
Mutants (Total: 2, Killed: 2, Survived: 0)
447: # first and then read the cache directly — avoids a second ref()+regex. 448: $db->_open_table({}); 449: my $table = $db->{'_table_name'}; 450: 451: my $select = $count_only ? 'COUNT(*)' : $self->{'_select'}; 452: my $query = "SELECT $select FROM $table"; 453: 454: if(@{$self->{'_joins'}}) { 455: $query .= ' ' . $db->_build_joins($self->{'_joins'}); 456: } 457: ●458 → 464 → 474 458: my $qwhere = $db->{'base_criteria'} 459: ? { %{$db->{'base_criteria'}}, %{$self->{'_where'}} } 460: : $self->{'_where'}; 461: my ($where, $wargs) = $db->_build_where($qwhere); 462: my @args = @{$wargs}; 463: 464: if(@{$self->{'_joins'}}) { 465: $query .= " WHERE $where" if $where; 466: } elsif(($db->{'type'} eq 'CSV') && !$db->{'no_entry'}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
467: my $id = $db->{'id'}; 468: $query .= " WHERE $id IS NOT NULL AND $id NOT LIKE '#%'"; 469: $query .= " AND ($where)" if $where; 470: } else {
Mutants (Total: 2, Killed: 2, Survived: 0)
471: $query .= " WHERE $where" if $where; 472: } 473: ●474 → 474 → 480 474: unless($count_only) { 475: $query .= " ORDER BY $self->{'_order_by'}" if defined $self->{'_order_by'}; 476: $query .= " LIMIT $self->{'_limit'}" if defined $self->{'_limit'}; 477: $query .= " OFFSET $self->{'_offset'}" if defined $self->{'_offset'}; 478: } 479: 480: return ($query, \@args, $table); 481: }
Mutants (Total: 2, Killed: 2, Survived: 0)
482: 483: =head2 all 484: 485: my $rows = $q->all(); 486: 487: B<Terminal method.> Executes the assembled query and returns an array 488: reference of hash references, one per matching row. Returns an empty 489: array reference when there are no matches (never C<undef>). 490: 491: =head3 API SPECIFICATION 492: 493: =head4 Arguments 494: 495: None. All query parameters are set via the builder methods before 496: calling C<all()>. 497: 498: =head4 Returns 499: 500: ArrayRef[HashRef] 501: 502: An arrayref of row hashrefs. Returns C<[]> (empty arrayref) when 503: no rows match -- never C<undef>. Each hashref is read-only unless 504: the database was constructed with C<< no_fixate => 1 >>. 505: 506: When C<measure()> has been called, delegates to C<< $db->aggregate() >> 507: and returns grouped rows (see L<Database::Abstraction/aggregate>). 508: 509: =cut 510:
Mutants (Total: 1, Killed: 1, Survived: 0)
511: sub all 512: { ●513 → 520 → 542 513: my $self = shift; 514: my $db = $self->{'_db'}; 515: 516: # Ensure _open() fires before checking the backend type. 517: $db->_open_table({}); 518: 519: # Aggregate path: delegate to $db->aggregate when measures have been set. 520: if(@{$self->{'_measures'}}) { 521: my %ap = (%{$self->{'_where'}}, measures => $self->{'_measures'});
Mutants (Total: 2, Killed: 2, Survived: 0)
522: $ap{'by'} = $self->{'_group_by'} if @{$self->{'_group_by'}}; 523: $ap{'having'} = $self->{'_having'} if %{$self->{'_having'}}; 524: if(@{$self->{'_joins'}}) { 525: $ap{'join'} = $self->{'_joins'}; 526: } 527: if(defined $self->{'_order_by'}) { 528: # Parse "col [ASC|DESC]" from order_by into sort_by format. 529: # Multi-column order_by expressions are not supported for aggregates; 530: # only the first token is used. 531: my ($col, $dir) = ($self->{'_order_by'} =~ /\A(\S+)(?:\s+(ASC|DESC))?\z/i); 532: $ap{'sort_by'} = defined($col) 533: ? (defined($dir) ? [$col, uc($dir)] : $col) 534: : undef; 535: delete $ap{'sort_by'} unless defined $ap{'sort_by'}; 536: } 537: $ap{'limit'} = $self->{'_limit'} if defined $self->{'_limit'};
Mutants (Total: 1, Killed: 1, Survived: 0)
538: $ap{'offset'} = $self->{'_offset'} if defined $self->{'_offset'}; 539: return $db->aggregate(%ap); 540: } 541:
Mutants (Total: 2, Killed: 2, Survived: 0)
●542 → 542 → 551 542: if($db->{'berkeley'} || ($db->{'type'} // '') =~ /\A(?:Deep|XLSX)\z/) { 543: my $backend = $db->{'berkeley'} ? 'BerkeleyDB' : ($db->{'type'} // ''); 544: croak(ref($db), ": query->all() with JOINs is not supported on $backend") 545: if @{$self->{'_joins'}}; 546: my $rows = $db->selectall_arrayref({%{$self->{'_where'}}}); 547: _apply_perl_sort_limit($rows, $self->{'_order_by'}, $self->{'_offset'}, $self->{'_limit'}); 548: return $rows; 549: } 550: ●551 → 558 → 561 551: my ($query, $args, $table) = $self->_build_sql(0); 552: $db->_debug("Query->all: $query"); 553: 554: my $sth = $db->{$table}->prepare_cached($query); 555: $sth->execute(@{$args}) or croak("$query: @{$args}"); 556: 557: my @rows; 558: while(my $row = $sth->fetchrow_hashref()) { 559: push @rows, $row; 560: } 561: return \@rows; 562: } 563: 564: =head2 first 565: 566: my $row = $q->first(); # \%hashref or undef 567: 568: B<Terminal method.> Executes the query with C<LIMIT 1> and returns the 569: first matching row as a hash reference, or C<undef> when there is no match. 570: Any C<limit()> or C<offset()> you have set is temporarily overridden for 571: efficiency (only the LIMIT is overridden; offset is still applied). 572: 573: =head3 API SPECIFICATION 574: 575: =head4 Arguments 576: 577: None. 578: 579: =head4 Returns 580: 581: HashRef | undef 582: 583: The first matching row hashref, or C<undef> when no row matches. 584: Internally applies C<LIMIT 1> for SQL backends; for in-memory 585: backends it returns the first element of the sorted result. 586: 587: When C<measure()> has been called, returns the first aggregate group 588: row (the same as C<< ->all()->[0] >>). 589: 590: =cut 591: 592: sub first 593: { ●594 → 599 → 605 594: my $self = shift; 595: my $db = $self->{'_db'}; 596: 597: $db->_open_table({}); 598: 599: if(@{$self->{'_measures'}}) { 600: local $self->{'_limit'} = 1; 601: my $rows = $self->all(); 602: return ref($rows) eq 'ARRAY' ? $rows->[0] : undef; 603: } 604: ●605 → 605 → 617 605: if($db->{'berkeley'} || ($db->{'type'} // '') =~ /\A(?:Deep|XLSX)\z/) { 606: my $backend = $db->{'berkeley'} ? 'BerkeleyDB' : ($db->{'type'} // ''); 607: croak(ref($db), ": query->first() with JOINs is not supported on $backend") 608: if @{$self->{'_joins'}}; 609: my $rows = $db->selectall_arrayref({%{$self->{'_where'}}}); 610: _apply_perl_sort_limit($rows, $self->{'_order_by'}, $self->{'_offset'}, undef); 611: return $rows->[0]; 612: } 613: 614: # local on a hash element (supported since Perl 5.8.1) is exception-safe: 615: # even if _build_sql() croaks, _limit is automatically restored on unwind. 616: # The previous save/restore pair left _limit permanently at 1 on exception. 617: local $self->{'_limit'} = 1; 618: my ($query, $args, $table) = $self->_build_sql(0); 619: 620: $db->_debug("Query->first: $query"); 621: 622: my $sth = $db->{$table}->prepare_cached($query); 623: $sth->execute(@{$args}) or croak("$query: @{$args}"); 624: 625: my $row = $sth->fetchrow_hashref(); 626: $sth->finish(); 627: return $row; 628: } 629: 630: =head2 count 631: 632: my $n = $q->count(); 633: 634: B<Terminal method.> Executes C<SELECT COUNT(*)> with the current C<WHERE> 635: and C<JOIN> clauses and returns the integer count. C<ORDER BY>, C<LIMIT>, 636: and C<OFFSET> are ignored for the count query. 637: 638: =head3 API SPECIFICATION 639: 640: =head4 Arguments 641: 642: None. 643: 644: =head4 Returns 645: 646: Int (>= 0) 647: 648: The number of matching rows. Returns C<0> when nothing matches -- 649: never C<undef>. 650: 651: B<Restriction:> croaks with 652: C<"count() is not available once measure() has been called"> 653: if any C<measure()> call has been made on this query builder. Use 654: C<all()> and examine C<scalar @{$rows}> instead. 655: 656: =cut 657: 658: sub count 659: { ●660 → 668 → 675 660: my $self = shift; 661: my $db = $self->{'_db'}; 662: 663: $db->_open_table({}); 664: 665: croak('Database::Abstraction::Query: count() is not available once measure() has been called') 666: if @{$self->{'_measures'}}; 667: 668: if($db->{'berkeley'} || ($db->{'type'} // '') =~ /\A(?:Deep|XLSX)\z/) { 669: my $backend = $db->{'berkeley'} ? 'BerkeleyDB' : ($db->{'type'} // ''); 670: croak(ref($db), ": query->count() with JOINs is not supported on $backend") 671: if @{$self->{'_joins'}}; 672: return $db->count({%{$self->{'_where'}}}); 673: } 674: 675: my ($query, $args, $table) = $self->_build_sql(1); 676: $db->_debug("Query->count: $query"); 677: 678: my $sth = $db->{$table}->prepare_cached($query); 679: $sth->execute(@{$args}) or croak("$query: @{$args}"); 680: 681: my $row = $sth->fetchrow_arrayref(); 682: $sth->finish(); 683: return $row ? $row->[0] : 0; 684: } 685: 686: =head2 each 687: 688: $q->each(\&callback); 689: $q->each(sub { my $row = shift; print $row->{'name'}, "\n" }); 690: 691: B<Terminal method.> Iterates over matching rows one at a time, calling 692: C<\&callback> once per row with the row hashref as the sole argument. 693: Uses constant memory on the SQL path (see L<Database::Abstraction/each_row>). 694: 695: Applies any C<where()>, C<join()>, C<order_by()>, C<limit()>, and C<offset()> 696: set on the builder. 697: 698: Returns the number of rows passed to C<\&callback>. 699: 700: =head3 API SPECIFICATION 701: 702: =head4 Arguments 703: 704: CodeRef # required: callback invoked with one row hashref per call 705: 706: =head4 Returns 707: 708: Int (>= 0) 709: 710: The number of rows visited. Any exception thrown inside the callback 711: is re-thrown after the DBI statement handle is properly closed. 712: 713: When C<measure()> has been called, each group row is passed to the 714: callback in the same order as C<all()> would return them. 715: 716: =cut 717: 718: sub each 719: { ●720 → 729 → 740 720: my ($self, $callback) = @_; 721: my $db = $self->{'_db'}; 722: 723: croak('Database::Abstraction::Query::each: callback must be a code reference') 724: unless ref($callback) eq 'CODE'; 725: 726: $db->_open_table({}); 727: 728: # Aggregate path: collect all rows then iterate. Not constant-memory. 729: if(@{$self->{'_measures'}}) { 730: my $rows = $self->all(); 731: my $n = 0; 732: for my $row (@{$rows}) { 733: local $_; 734: $callback->($row); 735: $n++; 736: } 737: return $n; 738: } 739: ●740 → 740 → 755 740: if($db->{'berkeley'} || ($db->{'type'} // '') =~ /\A(?:Deep|XLSX)\z/) { 741: my $backend = $db->{'berkeley'} ? 'BerkeleyDB' : ($db->{'type'} // ''); 742: croak(ref($db), ": query->each() with JOINs is not supported on $backend") 743: if @{$self->{'_joins'}}; 744: my $rows = $db->selectall_arrayref({%{$self->{'_where'}}}); 745: _apply_perl_sort_limit($rows, $self->{'_order_by'}, $self->{'_offset'}, $self->{'_limit'}); 746: my $n = 0; 747: for my $row (@{$rows}) { 748: local $_; 749: $callback->($row); 750: $n++; 751: } 752: return $n; 753: } 754: ●755 → 769 → 773 755: my ($query, $args, $table) = $self->_build_sql(0); 756: $db->_debug("Query->each: $query"); 757: 758: my $sth = $db->{$table}->prepare_cached($query); 759: $sth->execute(@{$args}) or croak("$query: @{$args}"); 760: 761: my $n = 0; 762: eval { 763: while(my $row = $sth->fetchrow_hashref()) { 764: local $_; 765: $callback->($row); 766: $n++; 767: } 768: }; 769: if(my $err = $@) { 770: $sth->finish(); 771: die $err; 772: } 773: return $n; 774: } 775: 776: =head1 SEE ALSO 777: 778: L<Database::Abstraction> - the parent module and its L<Database::Abstraction/QUERY CRITERIA> section. 779: 780: =head1 AUTHOR 781: 782: Nigel Horne, C<< <njh at nigelhorne.com> >> 783: 784: =head1 SUPPORT 785: 786: Please report bugs at 787: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Database-Abstraction>. 788: 789: =head1 COMMON PITFALLS 790: 791: =over 4 792: 793: =item B<C<where()> is AND, not OR> 794: 795: Each call to C<where()> ANDs with all previous C<where()> calls. 796: Use C<< -or => [...] >> inside a single C<where()> call for OR logic. 797: 798: =item B<C<measure()> calls accumulate> 799: 800: Every C<measure()> call appends a new measure to the query. To 801: build a fresh aggregate query call C<< $db->query() >> again rather 802: than re-using the same builder object. 803: 804: =item B<C<group_by()> replaces, not appends> 805: 806: Calling C<group_by()> a second time replaces the previous group-by 807: columns entirely. It does not accumulate like C<measure()> or 808: C<where()>. 809: 810: =item B<C<count()> is unavailable after C<measure()>> 811: 812: Once you have called C<measure()> on a query builder, calling 813: C<count()> will croak. Use C<all()> and check C<scalar @{$rows}>. 814: 815: =item B<Sort column for aggregate queries must use C<order_by()>> 816: 817: To sort aggregate results, call C<< ->order_by('col') >> on the 818: builder before C<< ->all() >>. Passing C<sort_by> directly to 819: C<all()> has no effect because the terminal method ignores extra 820: arguments. 821: 822: =back 823: 824: =head1 FORMAL SPECIFICATION 825: 826: =head2 Query builder state 827: 828: QueryState == [ 829: _db : Database::Abstraction, 830: _select : Str, 831: _where : CRITERIA, 832: _joins : seq JOIN_SPEC, 833: _order_by : Str | undef, 834: _limit : Int | undef, 835: _offset : Int | undef, 836: _group_by : seq COLNAME, 837: _measures : seq MEASURE_SPEC, 838: _having : CRITERIA 839: ] 840: 841: Initial state Q0 == [ 842: _select? = '*', 843: _where? = {}, 844: _joins? = [], 845: _order_by? = undef, 846: _limit? = undef, 847: _offset? = undef, 848: _group_by? = [], 849: _measures? = [], 850: _having? = {} 851: ] 852: 853: =head2 Builder method invariants 854: 855: where(C) ____________________________________________ 856: DeltaQueryState 857: C? : CRITERIA 858: ──────────────────────────────────────────────────── 859: post: _where' = _where UNION C (AND semantics) 860: 861: measure(col, fn, as) ________________________________ 862: DeltaQueryState 863: ──────────────────────────────────────────────────── 864: post: _measures' = _measures CONCAT [{col,fn,as}] 865: 866: group_by(cols) ______________________________________ 867: DeltaQueryState 868: ──────────────────────────────────────────────────── 869: post: _group_by' = cols (replaces previous value) 870: 871: =head2 all() dispatch 872: 873: all _________________________________________________ 874: XiQueryState (read-only) 875: ──────────────────────────────────────────────────── 876: result == (_measures != empty 877: IMPLIES _db.aggregate(_group_by, _measures, _where, 878: _having, _order_by, _limit, _offset) 879: ELSE _db.selectall_arrayref(_where, _joins, 880: _order_by, _limit, _offset)) 881: post: result : seq ROW 882: 883: =head1 LICENSE AND COPYRIGHT 884: 885: Copyright 2026 Nigel Horne. 886: 887: Usage is subject to the GPL2 licence terms. 888: If you use it, 889: please let me know. 890: 891: =cut 892: 893: 1;