1package #hide from PAUSE 2 DBIx::Class::Storage::DBIHacks; 3 4# 5# This module contains code supporting a battery of special cases and tests for 6# many corner cases pushing the envelope of what DBIC can do. When work on 7# these utilities began in mid 2009 (51a296b402c) it wasn't immediately obvious 8# that these pieces, despite their misleading on-first-sighe-flakiness, will 9# become part of the generic query rewriting machinery of DBIC, allowing it to 10# both generate and process queries representing incredibly complex sets with 11# reasonable efficiency. 12# 13# Now (end of 2019), more than 10 years later the routines in this class have 14# stabilized enough, and are meticulously covered with tests, to a point where 15# an effort to formalize them into user-facing APIs might be worthwhile. 16# 17# An implementor working on publicizing and/or replacing the routines with a 18# more modern SQL generation framework should keep in mind that pretty much all 19# existing tests are constructed on the basis of real-world code used in 20# production somewhere. 21# 22# Please hack on this responsibly ;) 23# 24 25use strict; 26use warnings; 27 28use base 'DBIx::Class::Storage'; 29use mro 'c3'; 30 31use Scalar::Util 'blessed'; 32use DBIx::Class::_Util qw(UNRESOLVABLE_CONDITION serialize); 33use SQL::Abstract::Util qw(is_plain_value is_literal_value); 34use DBIx::Class::Carp; 35use namespace::clean; 36 37# 38# This code will remove non-selecting/non-restricting joins from 39# {from} specs, aiding the RDBMS query optimizer 40# 41sub _prune_unused_joins { 42 my ($self, $attrs) = @_; 43 44 # only standard {from} specs are supported, and we could be disabled in general 45 return ($attrs->{from}, {}) unless ( 46 ref $attrs->{from} eq 'ARRAY' 47 and 48 @{$attrs->{from}} > 1 49 and 50 ref $attrs->{from}[0] eq 'HASH' 51 and 52 ref $attrs->{from}[1] eq 'ARRAY' 53 and 54 $self->_use_join_optimizer 55 ); 56 57 my $orig_aliastypes = $self->_resolve_aliastypes_from_select_args($attrs); 58 59 my $new_aliastypes = { %$orig_aliastypes }; 60 61 # we will be recreating this entirely 62 my @reclassify = 'joining'; 63 64 # a grouped set will not be affected by amount of rows. Thus any 65 # purely multiplicator classifications can go 66 # (will be reintroduced below if needed by something else) 67 push @reclassify, qw(multiplying premultiplied) 68 if $attrs->{_force_prune_multiplying_joins} or $attrs->{group_by}; 69 70 # nuke what will be recalculated 71 delete @{$new_aliastypes}{@reclassify}; 72 73 my @newfrom = $attrs->{from}[0]; # FROM head is always present 74 75 # recalculate what we need once the multipliers are potentially gone 76 # ignore premultiplies, since they do not add any value to anything 77 my %need_joins; 78 for ( @{$new_aliastypes}{grep { $_ ne 'premultiplied' } keys %$new_aliastypes }) { 79 # add all requested aliases 80 $need_joins{$_} = 1 for keys %$_; 81 82 # add all their parents (as per joinpath which is an AoH { table => alias }) 83 $need_joins{$_} = 1 for map { values %$_ } map { @{$_->{-parents}} } values %$_; 84 } 85 86 for my $j (@{$attrs->{from}}[1..$#{$attrs->{from}}]) { 87 push @newfrom, $j if ( 88 (! defined $j->[0]{-alias}) # legacy crap 89 || 90 $need_joins{$j->[0]{-alias}} 91 ); 92 } 93 94 # we have a new set of joiners - for everything we nuked pull the classification 95 # off the original stack 96 for my $ctype (@reclassify) { 97 $new_aliastypes->{$ctype} = { map 98 { $need_joins{$_} ? ( $_ => $orig_aliastypes->{$ctype}{$_} ) : () } 99 keys %{$orig_aliastypes->{$ctype}} 100 } 101 } 102 103 return ( \@newfrom, $new_aliastypes ); 104} 105 106# 107# This is the code producing joined subqueries like: 108# SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ... 109# 110sub _adjust_select_args_for_complex_prefetch { 111 my ($self, $attrs) = @_; 112 113 $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute') unless ( 114 ref $attrs->{from} eq 'ARRAY' 115 and 116 @{$attrs->{from}} > 1 117 and 118 ref $attrs->{from}[0] eq 'HASH' 119 and 120 ref $attrs->{from}[1] eq 'ARRAY' 121 ); 122 123 my $root_alias = $attrs->{alias}; 124 125 # generate inner/outer attribute lists, remove stuff that doesn't apply 126 my $outer_attrs = { %$attrs }; 127 delete @{$outer_attrs}{qw(from bind rows offset group_by _grouped_by_distinct having)}; 128 129 my $inner_attrs = { %$attrs, _simple_passthrough_construction => 1 }; 130 delete @{$inner_attrs}{qw(for collapse select as)}; 131 132 # there is no point of ordering the insides if there is no limit 133 delete $inner_attrs->{order_by} if ( 134 delete $inner_attrs->{_order_is_artificial} 135 or 136 ! $inner_attrs->{rows} 137 ); 138 139 # generate the inner/outer select lists 140 # for inside we consider only stuff *not* brought in by the prefetch 141 # on the outside we substitute any function for its alias 142 $outer_attrs->{select} = [ @{$attrs->{select}} ]; 143 144 my ($root_node, $root_node_offset); 145 146 for my $i (0 .. $#{$inner_attrs->{from}}) { 147 my $node = $inner_attrs->{from}[$i]; 148 my $h = (ref $node eq 'HASH') ? $node 149 : (ref $node eq 'ARRAY' and ref $node->[0] eq 'HASH') ? $node->[0] 150 : next 151 ; 152 153 if ( ($h->{-alias}||'') eq $root_alias and $h->{-rsrc} ) { 154 $root_node = $h; 155 $root_node_offset = $i; 156 last; 157 } 158 } 159 160 $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute') 161 unless $root_node; 162 163 # use the heavy duty resolver to take care of aliased/nonaliased naming 164 my $colinfo = $self->_resolve_column_info($inner_attrs->{from}); 165 my $selected_root_columns; 166 167 for my $i (0 .. $#{$outer_attrs->{select}}) { 168 my $sel = $outer_attrs->{select}->[$i]; 169 170 next if ( 171 $colinfo->{$sel} and $colinfo->{$sel}{-source_alias} ne $root_alias 172 ); 173 174 if (ref $sel eq 'HASH' ) { 175 $sel->{-as} ||= $attrs->{as}[$i]; 176 $outer_attrs->{select}->[$i] = join ('.', $root_alias, ($sel->{-as} || "inner_column_$i") ); 177 } 178 elsif (! ref $sel and my $ci = $colinfo->{$sel}) { 179 $selected_root_columns->{$ci->{-colname}} = 1; 180 } 181 182 push @{$inner_attrs->{select}}, $sel; 183 184 push @{$inner_attrs->{as}}, $attrs->{as}[$i]; 185 } 186 187 # We will need to fetch all native columns in the inner subquery, which may 188 # be a part of an *outer* join condition, or an order_by (which needs to be 189 # preserved outside), or wheres. In other words everything but the inner 190 # selector 191 # We can not just fetch everything because a potential has_many restricting 192 # join collapse *will not work* on heavy data types. 193 my $connecting_aliastypes = $self->_resolve_aliastypes_from_select_args({ 194 %$inner_attrs, 195 select => [], 196 }); 197 198 for (sort map { keys %{$_->{-seen_columns}||{}} } map { values %$_ } values %$connecting_aliastypes) { 199 my $ci = $colinfo->{$_} or next; 200 if ( 201 $ci->{-source_alias} eq $root_alias 202 and 203 ! $selected_root_columns->{$ci->{-colname}}++ 204 ) { 205 # adding it to both to keep limits not supporting dark selectors happy 206 push @{$inner_attrs->{select}}, $ci->{-fq_colname}; 207 push @{$inner_attrs->{as}}, $ci->{-fq_colname}; 208 } 209 } 210 211 # construct the inner {from} and lock it in a subquery 212 # we need to prune first, because this will determine if we need a group_by below 213 # throw away all non-selecting, non-restricting multijoins 214 # (since we def. do not care about multiplication of the contents of the subquery) 215 my $inner_subq = do { 216 217 # must use it here regardless of user requests (vastly gentler on optimizer) 218 local $self->{_use_join_optimizer} = 1; 219 220 # throw away multijoins since we def. do not care about those inside the subquery 221 ($inner_attrs->{from}, my $inner_aliastypes) = $self->_prune_unused_joins ({ 222 %$inner_attrs, _force_prune_multiplying_joins => 1 223 }); 224 225 # uh-oh a multiplier (which is not us) left in, this is a problem for limits 226 # we will need to add a group_by to collapse the resultset for proper counts 227 if ( 228 grep { $_ ne $root_alias } keys %{ $inner_aliastypes->{multiplying} || {} } 229 and 230 # if there are user-supplied groups - assume user knows wtf they are up to 231 ( ! $inner_aliastypes->{grouping} or $inner_attrs->{_grouped_by_distinct} ) 232 ) { 233 234 my $cur_sel = { map { $_ => 1 } @{$inner_attrs->{select}} }; 235 236 # *possibly* supplement the main selection with pks if not already 237 # there, as they will have to be a part of the group_by to collapse 238 # things properly 239 my $inner_select_with_extras; 240 my @pks = map { "$root_alias.$_" } $root_node->{-rsrc}->primary_columns 241 or $self->throw_exception( sprintf 242 'Unable to perform complex limited prefetch off %s without declared primary key', 243 $root_node->{-rsrc}->source_name, 244 ); 245 for my $col (@pks) { 246 push @{ $inner_select_with_extras ||= [ @{$inner_attrs->{select}} ] }, $col 247 unless $cur_sel->{$col}++; 248 } 249 250 ($inner_attrs->{group_by}, $inner_attrs->{order_by}) = $self->_group_over_selection({ 251 %$inner_attrs, 252 $inner_select_with_extras ? ( select => $inner_select_with_extras ) : (), 253 _aliastypes => $inner_aliastypes, 254 }); 255 } 256 257 # we already optimized $inner_attrs->{from} above 258 # and already local()ized 259 $self->{_use_join_optimizer} = 0; 260 261 # generate the subquery 262 $self->_select_args_to_query ( 263 @{$inner_attrs}{qw(from select where)}, 264 $inner_attrs, 265 ); 266 }; 267 268 # Generate the outer from - this is relatively easy (really just replace 269 # the join slot with the subquery), with a major caveat - we can not 270 # join anything that is non-selecting (not part of the prefetch), but at 271 # the same time is a multi-type relationship, as it will explode the result. 272 # 273 # There are two possibilities here 274 # - either the join is non-restricting, in which case we simply throw it away 275 # - it is part of the restrictions, in which case we need to collapse the outer 276 # result by tackling yet another group_by to the outside of the query 277 278 # work on a shallow copy 279 my @orig_from = @{$attrs->{from}}; 280 281 282 $outer_attrs->{from} = \ my @outer_from; 283 284 # we may not be the head 285 if ($root_node_offset) { 286 # first generate the outer_from, up to the substitution point 287 @outer_from = splice @orig_from, 0, $root_node_offset; 288 289 # substitute the subq at the right spot 290 push @outer_from, [ 291 { 292 -alias => $root_alias, 293 -rsrc => $root_node->{-rsrc}, 294 $root_alias => $inner_subq, 295 }, 296 # preserve attrs from what is now the head of the from after the splice 297 @{$orig_from[0]}[1 .. $#{$orig_from[0]}], 298 ]; 299 } 300 else { 301 @outer_from = { 302 -alias => $root_alias, 303 -rsrc => $root_node->{-rsrc}, 304 $root_alias => $inner_subq, 305 }; 306 } 307 308 shift @orig_from; # what we just replaced above 309 310 # scan the *remaining* from spec against different attributes, and see which joins are needed 311 # in what role 312 my $outer_aliastypes = $outer_attrs->{_aliastypes} = 313 $self->_resolve_aliastypes_from_select_args({ %$outer_attrs, from => \@orig_from }); 314 315 # unroll parents 316 my ($outer_select_chain, @outer_nonselecting_chains) = map { +{ 317 map { $_ => 1 } map { values %$_} map { @{$_->{-parents}} } values %{ $outer_aliastypes->{$_} || {} } 318 } } qw/selecting restricting grouping ordering/; 319 320 # see what's left - throw away if not selecting/restricting 321 my $may_need_outer_group_by; 322 while (my $j = shift @orig_from) { 323 my $alias = $j->[0]{-alias}; 324 325 if ( 326 $outer_select_chain->{$alias} 327 ) { 328 push @outer_from, $j 329 } 330 elsif (grep { $_->{$alias} } @outer_nonselecting_chains ) { 331 push @outer_from, $j; 332 $may_need_outer_group_by ||= $outer_aliastypes->{multiplying}{$alias} ? 1 : 0; 333 } 334 } 335 336 # also throw in a synthetic group_by if a non-selecting multiplier, 337 # to guard against cross-join explosions 338 # the logic is somewhat fragile, but relies on the idea that if a user supplied 339 # a group by on their own - they know what they were doing 340 if ( $may_need_outer_group_by and $attrs->{_grouped_by_distinct} ) { 341 ($outer_attrs->{group_by}, $outer_attrs->{order_by}) = $self->_group_over_selection ({ 342 %$outer_attrs, 343 from => \@outer_from, 344 }); 345 } 346 347 # FIXME: The {where} ends up in both the inner and outer query, i.e. *twice* 348 # 349 # This is rather horrific, and while we currently *do* have enough 350 # introspection tooling available to attempt a stab at properly deciding 351 # whether or not to include the where condition on the outside, the 352 # machinery is still too slow to apply it here. 353 # Thus for the time being we do not attempt any sanitation of the where 354 # clause and just pass it through on both sides of the subquery. This *will* 355 # be addressed at a later stage, most likely after folding the SQL generator 356 # into SQLMaker proper 357 # 358 # OTOH it can be seen as a plus: <ash> (notes that this query would make a DBA cry ;) 359 # 360 return $outer_attrs; 361} 362 363# 364# This is probably the ickiest, yet most relied upon part of the codebase: 365# this is the place where we take arbitrary SQL input and break it into its 366# constituent parts, making sure we know which *sources* are used in what 367# *capacity* ( selecting / restricting / grouping / ordering / joining, etc. ) 368# Although the method is pretty horrific, the worst thing that can happen is 369# for a classification failure, which in turn will result in a vocal exception, 370# and will lead to a relatively prompt fix. 371# The code has been slowly improving and is covered with a formiddable battery 372# of tests, so can be considered "reliably stable" at this point (Oct 2015). 373# 374# A note to implementors attempting to "replace" this - keep in mind that while 375# there are multiple optimization avenues, the actual "scan literal elements" 376# part *MAY NEVER BE REMOVED*, even if in the future it is limited to only AST 377# nodes that are deemed opaque (i.e. contain literal expressions). The use and 378# comprehension of blackbox literals is at this point firmly a user-facing API, 379# and is one of *the* reasons DBIC remains as flexible as it is. 380# 381# In other words, when working on this keep in mind that the following is both 382# a widespread and *encouraged* way of using DBIC in the wild when push comes 383# to shove: 384# 385# $rs->search( {}, { 386# select => \[ $random, @stuff], 387# from => \[ $random, @stuff ], 388# where => \[ $random, @stuff ], 389# group_by => \[ $random, @stuff ], 390# order_by => \[ $random, @stuff ], 391# } ) 392# 393# Various incarnations of the above are reflected in many of the tests. If one 394# gets to fail, or if a user complains: you get to fix it. A stance amounting 395# to "this is crazy, nobody does that" is not acceptable going forward. 396# 397sub _resolve_aliastypes_from_select_args { 398 my ( $self, $attrs ) = @_; 399 400 $self->throw_exception ('Unable to analyze custom {from}') 401 if ref $attrs->{from} ne 'ARRAY'; 402 403 # what we will return 404 my $aliases_by_type; 405 406 # see what aliases are there to work with 407 # and record who is a multiplier and who is premultiplied 408 my $alias_list; 409 for my $node (@{$attrs->{from}}) { 410 411 my $j = $node; 412 $j = $j->[0] if ref $j eq 'ARRAY'; 413 my $al = $j->{-alias} 414 or next; 415 416 $alias_list->{$al} = $j; 417 418 $aliases_by_type->{multiplying}{$al} ||= { -parents => $j->{-join_path}||[] } 419 # not array == {from} head == can't be multiplying 420 if ref($node) eq 'ARRAY' and ! $j->{-is_single}; 421 422 $aliases_by_type->{premultiplied}{$al} ||= { -parents => $j->{-join_path}||[] } 423 # parts of the path that are not us but are multiplying 424 if grep { $aliases_by_type->{multiplying}{$_} } 425 grep { $_ ne $al } 426 map { values %$_ } 427 @{ $j->{-join_path}||[] } 428 } 429 430 # get a column to source/alias map (including unambiguous unqualified ones) 431 my $colinfo = $self->_resolve_column_info ($attrs->{from}); 432 433 # set up a botched SQLMaker 434 my $sql_maker = $self->sql_maker; 435 436 # these are throw away results, do not pollute the bind stack 437 local $sql_maker->{where_bind}; 438 local $sql_maker->{group_bind}; 439 local $sql_maker->{having_bind}; 440 local $sql_maker->{from_bind}; 441 442 # we can't scan properly without any quoting (\b doesn't cut it 443 # everywhere), so unless there is proper quoting set - use our 444 # own weird impossible character. 445 # Also in the case of no quoting, we need to explicitly disable 446 # name_sep, otherwise sorry nasty legacy syntax like 447 # { 'count(foo.id)' => { '>' => 3 } } will stop working >:( 448 local $sql_maker->{quote_char} = $sql_maker->{quote_char}; 449 local $sql_maker->{name_sep} = $sql_maker->{name_sep}; 450 451 unless (defined $sql_maker->{quote_char} and length $sql_maker->{quote_char}) { 452 $sql_maker->{quote_char} = ["\x00", "\xFF"]; 453 # if we don't unset it we screw up retarded but unfortunately working 454 # 'MAX(foo.bar)' => { '>', 3 } 455 $sql_maker->{name_sep} = ''; 456 } 457 458 my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep); 459 460 # generate sql chunks 461 my $to_scan = { 462 restricting => [ 463 ($sql_maker->_recurse_where ($attrs->{where}))[0], 464 $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} }), 465 ], 466 grouping => [ 467 $sql_maker->_parse_rs_attrs ({ group_by => $attrs->{group_by} }), 468 ], 469 joining => [ 470 $sql_maker->_recurse_from ( 471 ref $attrs->{from}[0] eq 'ARRAY' ? $attrs->{from}[0][0] : $attrs->{from}[0], 472 @{$attrs->{from}}[1 .. $#{$attrs->{from}}], 473 ), 474 ], 475 selecting => [ 476 map { ($sql_maker->_recurse_fields($_))[0] } @{$attrs->{select}}, 477 ], 478 ordering => [ 479 map { $_->[0] } $self->_extract_order_criteria ($attrs->{order_by}, $sql_maker), 480 ], 481 }; 482 483 # throw away empty chunks and all 2-value arrayrefs: the thinking is that these are 484 # bind value specs left in by the sloppy renderer above. It is ok to do this 485 # at this point, since we are going to end up rewriting this crap anyway 486 for my $v (values %$to_scan) { 487 my @nv; 488 for (@$v) { 489 next if ( 490 ! defined $_ 491 or 492 ( 493 ref $_ eq 'ARRAY' 494 and 495 ( @$_ == 0 or @$_ == 2 ) 496 ) 497 ); 498 499 if (ref $_) { 500 require Data::Dumper::Concise; 501 $self->throw_exception("Unexpected ref in scan-plan: " . Data::Dumper::Concise::Dumper($v) ); 502 } 503 504 push @nv, $_; 505 } 506 507 $v = \@nv; 508 } 509 510 # kill all selectors which look like a proper subquery 511 # this is a sucky heuristic *BUT* - if we get it wrong the query will simply 512 # fail to run, so we are relatively safe 513 $to_scan->{selecting} = [ grep { 514 $_ !~ / \A \s* \( \s* SELECT \s+ .+? \s+ FROM \s+ .+? \) \s* \z /xsi 515 } @{ $to_scan->{selecting} || [] } ]; 516 517 # first see if we have any exact matches (qualified or unqualified) 518 for my $type (keys %$to_scan) { 519 for my $piece (@{$to_scan->{$type}}) { 520 if ($colinfo->{$piece} and my $alias = $colinfo->{$piece}{-source_alias}) { 521 $aliases_by_type->{$type}{$alias} ||= { -parents => $alias_list->{$alias}{-join_path}||[] }; 522 $aliases_by_type->{$type}{$alias}{-seen_columns}{$colinfo->{$piece}{-fq_colname}} = $piece; 523 } 524 } 525 } 526 527 # now loop through all fully qualified columns and get the corresponding 528 # alias (should work even if they are in scalarrefs) 529 for my $alias (keys %$alias_list) { 530 my $al_re = qr/ 531 $lquote $alias $rquote $sep (?: $lquote ([^$rquote]+) $rquote )? 532 | 533 \b $alias \. ([^\s\)\($rquote]+)? 534 /x; 535 536 for my $type (keys %$to_scan) { 537 for my $piece (@{$to_scan->{$type}}) { 538 if (my @matches = $piece =~ /$al_re/g) { 539 $aliases_by_type->{$type}{$alias} ||= { -parents => $alias_list->{$alias}{-join_path}||[] }; 540 $aliases_by_type->{$type}{$alias}{-seen_columns}{"$alias.$_"} = "$alias.$_" 541 for grep { defined $_ } @matches; 542 } 543 } 544 } 545 } 546 547 # now loop through unqualified column names, and try to locate them within 548 # the chunks 549 for my $col (keys %$colinfo) { 550 next if $col =~ / \. /x; # if column is qualified it was caught by the above 551 552 my $col_re = qr/ $lquote ($col) $rquote /x; 553 554 for my $type (keys %$to_scan) { 555 for my $piece (@{$to_scan->{$type}}) { 556 if ( my @matches = $piece =~ /$col_re/g) { 557 my $alias = $colinfo->{$col}{-source_alias}; 558 $aliases_by_type->{$type}{$alias} ||= { -parents => $alias_list->{$alias}{-join_path}||[] }; 559 $aliases_by_type->{$type}{$alias}{-seen_columns}{"$alias.$_"} = $_ 560 for grep { defined $_ } @matches; 561 } 562 } 563 } 564 } 565 566 # Add any non-left joins to the restriction list (such joins are indeed restrictions) 567 for my $j (values %$alias_list) { 568 my $alias = $j->{-alias} or next; 569 $aliases_by_type->{restricting}{$alias} ||= { -parents => $j->{-join_path}||[] } if ( 570 (not $j->{-join_type}) 571 or 572 ($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi) 573 ); 574 } 575 576 for (keys %$aliases_by_type) { 577 delete $aliases_by_type->{$_} unless keys %{$aliases_by_type->{$_}}; 578 } 579 580 return $aliases_by_type; 581} 582 583# This is the engine behind { distinct => 1 } and the general 584# complex prefetch grouper 585sub _group_over_selection { 586 my ($self, $attrs) = @_; 587 588 my $colinfos = $self->_resolve_column_info ($attrs->{from}); 589 590 my (@group_by, %group_index); 591 592 # the logic is: if it is a { func => val } we assume an aggregate, 593 # otherwise if \'...' or \[...] we assume the user knows what is 594 # going on thus group over it 595 for (@{$attrs->{select}}) { 596 if (! ref($_) or ref ($_) ne 'HASH' ) { 597 push @group_by, $_; 598 $group_index{$_}++; 599 if ($colinfos->{$_} and $_ !~ /\./ ) { 600 # add a fully qualified version as well 601 $group_index{"$colinfos->{$_}{-source_alias}.$_"}++; 602 } 603 } 604 } 605 606 my @order_by = $self->_extract_order_criteria($attrs->{order_by}) 607 or return (\@group_by, $attrs->{order_by}); 608 609 # add any order_by parts that are not already present in the group_by 610 # to maintain SQL cross-compatibility and general sanity 611 # 612 # also in case the original selection is *not* unique, or in case part 613 # of the ORDER BY refers to a multiplier - we will need to replace the 614 # skipped order_by elements with their MIN/MAX equivalents as to maintain 615 # the proper overall order without polluting the group criteria (and 616 # possibly changing the outcome entirely) 617 618 my ($leftovers, $sql_maker, @new_order_by, $order_chunks, $aliastypes); 619 620 my $group_already_unique = $self->_columns_comprise_identifying_set($colinfos, \@group_by); 621 622 for my $o_idx (0 .. $#order_by) { 623 624 # if the chunk is already a min/max function - there is nothing left to touch 625 next if $order_by[$o_idx][0] =~ /^ (?: min | max ) \s* \( .+ \) $/ix; 626 627 # only consider real columns (for functions the user got to do an explicit group_by) 628 my $chunk_ci; 629 if ( 630 @{$order_by[$o_idx]} != 1 631 or 632 # only declare an unknown *plain* identifier as "leftover" if we are called with 633 # aliastypes to examine. If there are none - we are still in _resolve_attrs, and 634 # can just assume the user knows what they want 635 ( ! ( $chunk_ci = $colinfos->{$order_by[$o_idx][0]} ) and $attrs->{_aliastypes} ) 636 ) { 637 push @$leftovers, $order_by[$o_idx][0]; 638 } 639 640 next unless $chunk_ci; 641 642 # no duplication of group criteria 643 next if $group_index{$chunk_ci->{-fq_colname}}; 644 645 $aliastypes ||= ( 646 $attrs->{_aliastypes} 647 or 648 $self->_resolve_aliastypes_from_select_args({ 649 from => $attrs->{from}, 650 order_by => $attrs->{order_by}, 651 }) 652 ) if $group_already_unique; 653 654 # check that we are not ordering by a multiplier (if a check is requested at all) 655 if ( 656 $group_already_unique 657 and 658 ! $aliastypes->{multiplying}{$chunk_ci->{-source_alias}} 659 and 660 ! $aliastypes->{premultiplied}{$chunk_ci->{-source_alias}} 661 ) { 662 push @group_by, $chunk_ci->{-fq_colname}; 663 $group_index{$chunk_ci->{-fq_colname}}++ 664 } 665 else { 666 # We need to order by external columns without adding them to the group 667 # (eiehter a non-unique selection, or a multi-external) 668 # 669 # This doesn't really make sense in SQL, however from DBICs point 670 # of view is rather valid (e.g. order the leftmost objects by whatever 671 # criteria and get the offset/rows many). There is a way around 672 # this however in SQL - we simply tae the direction of each piece 673 # of the external order and convert them to MIN(X) for ASC or MAX(X) 674 # for DESC, and group_by the root columns. The end result should be 675 # exactly what we expect 676 # 677 678 # both populated on the first loop over $o_idx 679 $sql_maker ||= $self->sql_maker; 680 $order_chunks ||= [ 681 map { ref $_ eq 'ARRAY' ? $_ : [ $_ ] } $sql_maker->_order_by_chunks($attrs->{order_by}) 682 ]; 683 684 my ($chunk, $is_desc) = $sql_maker->_split_order_chunk($order_chunks->[$o_idx][0]); 685 686 $new_order_by[$o_idx] = \[ 687 sprintf( '%s( %s )%s', 688 $self->_minmax_operator_for_datatype($chunk_ci->{data_type}, $is_desc), 689 $chunk, 690 ($is_desc ? ' DESC' : ''), 691 ), 692 @ {$order_chunks->[$o_idx]} [ 1 .. $#{$order_chunks->[$o_idx]} ] 693 ]; 694 } 695 } 696 697 $self->throw_exception ( sprintf 698 'Unable to programatically derive a required group_by from the supplied ' 699 . 'order_by criteria. To proceed either add an explicit group_by, or ' 700 . 'simplify your order_by to only include plain columns ' 701 . '(supplied order_by: %s)', 702 join ', ', map { "'$_'" } @$leftovers, 703 ) if $leftovers; 704 705 # recreate the untouched order parts 706 if (@new_order_by) { 707 $new_order_by[$_] ||= \ $order_chunks->[$_] for ( 0 .. $#$order_chunks ); 708 } 709 710 return ( 711 \@group_by, 712 (@new_order_by ? \@new_order_by : $attrs->{order_by} ), # same ref as original == unchanged 713 ); 714} 715 716sub _minmax_operator_for_datatype { 717 #my ($self, $datatype, $want_max) = @_; 718 719 $_[2] ? 'MAX' : 'MIN'; 720} 721 722sub _resolve_ident_sources { 723 my ($self, $ident) = @_; 724 725 my $alias2source = {}; 726 727 # the reason this is so contrived is that $ident may be a {from} 728 # structure, specifying multiple tables to join 729 if ( blessed $ident && $ident->isa("DBIx::Class::ResultSource") ) { 730 # this is compat mode for insert/update/delete which do not deal with aliases 731 $alias2source->{me} = $ident; 732 } 733 elsif (ref $ident eq 'ARRAY') { 734 735 for (@$ident) { 736 my $tabinfo; 737 if (ref $_ eq 'HASH') { 738 $tabinfo = $_; 739 } 740 if (ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH') { 741 $tabinfo = $_->[0]; 742 } 743 744 $alias2source->{$tabinfo->{-alias}} = $tabinfo->{-rsrc} 745 if ($tabinfo->{-rsrc}); 746 } 747 } 748 749 return $alias2source; 750} 751 752# Takes $ident, \@column_names 753# 754# returns { $column_name => \%column_info, ... } 755# also note: this adds -result_source => $rsrc to the column info 756# 757# If no columns_names are supplied returns info about *all* columns 758# for all sources 759sub _resolve_column_info { 760 my ($self, $ident, $colnames) = @_; 761 762 return {} if $colnames and ! @$colnames; 763 764 my $alias2src = $self->_resolve_ident_sources($ident); 765 766 my (%seen_cols, @auto_colnames); 767 768 # compile a global list of column names, to be able to properly 769 # disambiguate unqualified column names (if at all possible) 770 for my $alias (keys %$alias2src) { 771 my $rsrc = $alias2src->{$alias}; 772 for my $colname ($rsrc->columns) { 773 push @{$seen_cols{$colname}}, $alias; 774 push @auto_colnames, "$alias.$colname" unless $colnames; 775 } 776 } 777 778 $colnames ||= [ 779 @auto_colnames, 780 grep { @{$seen_cols{$_}} == 1 } (keys %seen_cols), 781 ]; 782 783 my (%return, $colinfos); 784 foreach my $col (@$colnames) { 785 my ($source_alias, $colname) = $col =~ m/^ (?: ([^\.]+) \. )? (.+) $/x; 786 787 # if the column was seen exactly once - we know which rsrc it came from 788 $source_alias ||= $seen_cols{$colname}[0] 789 if ($seen_cols{$colname} and @{$seen_cols{$colname}} == 1); 790 791 next unless $source_alias; 792 793 my $rsrc = $alias2src->{$source_alias} 794 or next; 795 796 $return{$col} = { 797 %{ 798 ( $colinfos->{$source_alias} ||= $rsrc->columns_info )->{$colname} 799 || 800 $self->throw_exception( 801 "No such column '$colname' on source " . $rsrc->source_name 802 ); 803 }, 804 -result_source => $rsrc, 805 -source_alias => $source_alias, 806 -fq_colname => $col eq $colname ? "$source_alias.$col" : $col, 807 -colname => $colname, 808 }; 809 810 $return{"$source_alias.$colname"} = $return{$col} if $col eq $colname; 811 } 812 813 return \%return; 814} 815 816# The DBIC relationship chaining implementation is pretty simple - every 817# new related_relationship is pushed onto the {from} stack, and the {select} 818# window simply slides further in. This means that when we count somewhere 819# in the middle, we got to make sure that everything in the join chain is an 820# actual inner join, otherwise the count will come back with unpredictable 821# results (a resultset may be generated with _some_ rows regardless of if 822# the relation which the $rs currently selects has rows or not). E.g. 823# $artist_rs->cds->count - normally generates: 824# SELECT COUNT( * ) FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid 825# which actually returns the number of artists * (number of cds || 1) 826# 827# So what we do here is crawl {from}, determine if the current alias is at 828# the top of the stack, and if not - make sure the chain is inner-joined down 829# to the root. 830# 831sub _inner_join_to_node { 832 my ($self, $from, $alias) = @_; 833 834 my $switch_branch = $self->_find_join_path_to_node($from, $alias); 835 836 return $from unless @{$switch_branch||[]}; 837 838 # So it looks like we will have to switch some stuff around. 839 # local() is useless here as we will be leaving the scope 840 # anyway, and deep cloning is just too fucking expensive 841 # So replace the first hashref in the node arrayref manually 842 my @new_from = ($from->[0]); 843 my $sw_idx = { map { (values %$_), 1 } @$switch_branch }; #there's one k/v per join-path 844 845 for my $j (@{$from}[1 .. $#$from]) { 846 my $jalias = $j->[0]{-alias}; 847 848 if ($sw_idx->{$jalias}) { 849 my %attrs = %{$j->[0]}; 850 delete $attrs{-join_type}; 851 push @new_from, [ 852 \%attrs, 853 @{$j}[ 1 .. $#$j ], 854 ]; 855 } 856 else { 857 push @new_from, $j; 858 } 859 } 860 861 return \@new_from; 862} 863 864sub _find_join_path_to_node { 865 my ($self, $from, $target_alias) = @_; 866 867 # subqueries and other oddness are naturally not supported 868 return undef if ( 869 ref $from ne 'ARRAY' 870 || 871 ref $from->[0] ne 'HASH' 872 || 873 ! defined $from->[0]{-alias} 874 ); 875 876 # no path - the head is the alias 877 return [] if $from->[0]{-alias} eq $target_alias; 878 879 for my $i (1 .. $#$from) { 880 return $from->[$i][0]{-join_path} if ( ($from->[$i][0]{-alias}||'') eq $target_alias ); 881 } 882 883 # something else went quite wrong 884 return undef; 885} 886 887sub _extract_order_criteria { 888 my ($self, $order_by, $sql_maker) = @_; 889 890 my $parser = sub { 891 my ($sql_maker, $order_by, $orig_quote_chars) = @_; 892 893 return scalar $sql_maker->_order_by_chunks ($order_by) 894 unless wantarray; 895 896 my ($lq, $rq, $sep) = map { quotemeta($_) } ( 897 ($orig_quote_chars ? @$orig_quote_chars : $sql_maker->_quote_chars), 898 $sql_maker->name_sep 899 ); 900 901 my @chunks; 902 for ($sql_maker->_order_by_chunks ($order_by) ) { 903 my $chunk = ref $_ ? [ @$_ ] : [ $_ ]; 904 ($chunk->[0]) = $sql_maker->_split_order_chunk($chunk->[0]); 905 906 # order criteria may have come back pre-quoted (literals and whatnot) 907 # this is fragile, but the best we can currently do 908 $chunk->[0] =~ s/^ $lq (.+?) $rq $sep $lq (.+?) $rq $/"$1.$2"/xe 909 or $chunk->[0] =~ s/^ $lq (.+) $rq $/$1/x; 910 911 push @chunks, $chunk; 912 } 913 914 return @chunks; 915 }; 916 917 if ($sql_maker) { 918 return $parser->($sql_maker, $order_by); 919 } 920 else { 921 $sql_maker = $self->sql_maker; 922 923 # pass these in to deal with literals coming from 924 # the user or the deep guts of prefetch 925 my $orig_quote_chars = [$sql_maker->_quote_chars]; 926 927 local $sql_maker->{quote_char}; 928 return $parser->($sql_maker, $order_by, $orig_quote_chars); 929 } 930} 931 932sub _order_by_is_stable { 933 my ($self, $ident, $order_by, $where) = @_; 934 935 my @cols = ( 936 ( map { $_->[0] } $self->_extract_order_criteria($order_by) ), 937 ( $where ? keys %{ $self->_extract_fixed_condition_columns($where) } : () ), 938 ) or return 0; 939 940 my $colinfo = $self->_resolve_column_info($ident, \@cols); 941 942 return keys %$colinfo 943 ? $self->_columns_comprise_identifying_set( $colinfo, \@cols ) 944 : 0 945 ; 946} 947 948sub _columns_comprise_identifying_set { 949 my ($self, $colinfo, $columns) = @_; 950 951 my $cols_per_src; 952 $cols_per_src -> {$_->{-source_alias}} -> {$_->{-colname}} = $_ 953 for grep { defined $_ } @{$colinfo}{@$columns}; 954 955 for (values %$cols_per_src) { 956 my $src = (values %$_)[0]->{-result_source}; 957 return 1 if $src->_identifying_column_set($_); 958 } 959 960 return 0; 961} 962 963# this is almost similar to _order_by_is_stable, except it takes 964# a single rsrc, and will succeed only if the first portion of the order 965# by is stable. 966# returns that portion as a colinfo hashref on success 967sub _extract_colinfo_of_stable_main_source_order_by_portion { 968 my ($self, $attrs) = @_; 969 970 my $nodes = $self->_find_join_path_to_node($attrs->{from}, $attrs->{alias}); 971 972 return unless defined $nodes; 973 974 my @ord_cols = map 975 { $_->[0] } 976 ( $self->_extract_order_criteria($attrs->{order_by}) ) 977 ; 978 return unless @ord_cols; 979 980 my $valid_aliases = { map { $_ => 1 } ( 981 $attrs->{from}[0]{-alias}, 982 map { values %$_ } @$nodes, 983 ) }; 984 985 my $colinfos = $self->_resolve_column_info($attrs->{from}); 986 987 my ($colinfos_to_return, $seen_main_src_cols); 988 989 for my $col (@ord_cols) { 990 # if order criteria is unresolvable - there is nothing we can do 991 my $colinfo = $colinfos->{$col} or last; 992 993 # if we reached the end of the allowed aliases - also nothing we can do 994 last unless $valid_aliases->{$colinfo->{-source_alias}}; 995 996 $colinfos_to_return->{$col} = $colinfo; 997 998 $seen_main_src_cols->{$colinfo->{-colname}} = 1 999 if $colinfo->{-source_alias} eq $attrs->{alias}; 1000 } 1001 1002 # FIXME the condition may be singling out things on its own, so we 1003 # conceivable could come back wi "stable-ordered by nothing" 1004 # not confient enough in the parser yet, so punt for the time being 1005 return unless $seen_main_src_cols; 1006 1007 my $main_src_fixed_cols_from_cond = [ $attrs->{where} 1008 ? ( 1009 map 1010 { 1011 ( $colinfos->{$_} and $colinfos->{$_}{-source_alias} eq $attrs->{alias} ) 1012 ? $colinfos->{$_}{-colname} 1013 : () 1014 } 1015 keys %{ $self->_extract_fixed_condition_columns($attrs->{where}) } 1016 ) 1017 : () 1018 ]; 1019 1020 return $attrs->{result_source}->_identifying_column_set([ 1021 keys %$seen_main_src_cols, 1022 @$main_src_fixed_cols_from_cond, 1023 ]) ? $colinfos_to_return : (); 1024} 1025 1026# Attempts to flatten a passed in SQLAC condition as much as possible towards 1027# a plain hashref, *without* altering its semantics. Required by 1028# create/populate being able to extract definitive conditions from preexisting 1029# resultset {where} stacks 1030# 1031# FIXME - while relatively robust, this is still imperfect, one of the first 1032# things to tackle when we get access to a formalized AST. Note that this code 1033# is covered by a *ridiculous* amount of tests, so starting with porting this 1034# code would be a rather good exercise 1035sub _collapse_cond { 1036 my ($self, $where, $where_is_anded_array) = @_; 1037 1038 my $fin; 1039 1040 if (! $where) { 1041 return; 1042 } 1043 elsif ($where_is_anded_array or ref $where eq 'HASH') { 1044 1045 my @pairs; 1046 1047 my @pieces = $where_is_anded_array ? @$where : $where; 1048 while (@pieces) { 1049 my $chunk = shift @pieces; 1050 1051 if (ref $chunk eq 'HASH') { 1052 for (sort keys %$chunk) { 1053 1054 # Match SQLAC 1.79 behavior 1055 if ($_ eq '') { 1056 is_literal_value($chunk->{$_}) 1057 ? carp 'Hash-pairs consisting of an empty string with a literal are deprecated, use -and => [ $literal ] instead' 1058 : $self->throw_exception("Supplying an empty left hand side argument is not supported in hash-pairs") 1059 ; 1060 } 1061 1062 push @pairs, $_ => $chunk->{$_}; 1063 } 1064 } 1065 elsif (ref $chunk eq 'ARRAY') { 1066 push @pairs, -or => $chunk 1067 if @$chunk; 1068 } 1069 elsif ( ! length ref $chunk) { 1070 1071 # Match SQLAC 1.79 behavior 1072 $self->throw_exception("Supplying an empty left hand side argument is not supported in array-pairs") 1073 if $where_is_anded_array and (! defined $chunk or $chunk eq ''); 1074 1075 push @pairs, $chunk, shift @pieces; 1076 } 1077 else { 1078 push @pairs, '', $chunk; 1079 } 1080 } 1081 1082 return unless @pairs; 1083 1084 my @conds = $self->_collapse_cond_unroll_pairs(\@pairs) 1085 or return; 1086 1087 # Consolidate various @conds back into something more compact 1088 for my $c (@conds) { 1089 if (ref $c ne 'HASH') { 1090 push @{$fin->{-and}}, $c; 1091 } 1092 else { 1093 for my $col (sort keys %$c) { 1094 1095 # consolidate all -and nodes 1096 if ($col =~ /^\-and$/i) { 1097 push @{$fin->{-and}}, 1098 ref $c->{$col} eq 'ARRAY' ? @{$c->{$col}} 1099 : ref $c->{$col} eq 'HASH' ? %{$c->{$col}} 1100 : { $col => $c->{$col} } 1101 ; 1102 } 1103 elsif ($col =~ /^\-/) { 1104 push @{$fin->{-and}}, { $col => $c->{$col} }; 1105 } 1106 elsif (exists $fin->{$col}) { 1107 $fin->{$col} = [ -and => map { 1108 (ref $_ eq 'ARRAY' and ($_->[0]||'') =~ /^\-and$/i ) 1109 ? @{$_}[1..$#$_] 1110 : $_ 1111 ; 1112 } ($fin->{$col}, $c->{$col}) ]; 1113 } 1114 else { 1115 $fin->{$col} = $c->{$col}; 1116 } 1117 } 1118 } 1119 } 1120 } 1121 elsif (ref $where eq 'ARRAY') { 1122 # we are always at top-level here, it is safe to dump empty *standalone* pieces 1123 my $fin_idx; 1124 1125 for (my $i = 0; $i <= $#$where; $i++ ) { 1126 1127 # Match SQLAC 1.79 behavior 1128 $self->throw_exception( 1129 "Supplying an empty left hand side argument is not supported in array-pairs" 1130 ) if (! defined $where->[$i] or ! length $where->[$i]); 1131 1132 my $logic_mod = lc ( ($where->[$i] =~ /^(\-(?:and|or))$/i)[0] || '' ); 1133 1134 if ($logic_mod) { 1135 $i++; 1136 $self->throw_exception("Unsupported top-level op/arg pair: [ $logic_mod => $where->[$i] ]") 1137 unless ref $where->[$i] eq 'HASH' or ref $where->[$i] eq 'ARRAY'; 1138 1139 my $sub_elt = $self->_collapse_cond({ $logic_mod => $where->[$i] }) 1140 or next; 1141 1142 my @keys = keys %$sub_elt; 1143 if ( @keys == 1 and $keys[0] !~ /^\-/ ) { 1144 $fin_idx->{ "COL_$keys[0]_" . serialize $sub_elt } = $sub_elt; 1145 } 1146 else { 1147 $fin_idx->{ "SER_" . serialize $sub_elt } = $sub_elt; 1148 } 1149 } 1150 elsif (! length ref $where->[$i] ) { 1151 my $sub_elt = $self->_collapse_cond({ @{$where}[$i, $i+1] }) 1152 or next; 1153 1154 $fin_idx->{ "COL_$where->[$i]_" . serialize $sub_elt } = $sub_elt; 1155 $i++; 1156 } 1157 else { 1158 $fin_idx->{ "SER_" . serialize $where->[$i] } = $self->_collapse_cond( $where->[$i] ) || next; 1159 } 1160 } 1161 1162 if (! $fin_idx) { 1163 return; 1164 } 1165 elsif ( keys %$fin_idx == 1 ) { 1166 $fin = (values %$fin_idx)[0]; 1167 } 1168 else { 1169 my @or; 1170 1171 # at this point everything is at most one level deep - unroll if needed 1172 for (sort keys %$fin_idx) { 1173 if ( ref $fin_idx->{$_} eq 'HASH' and keys %{$fin_idx->{$_}} == 1 ) { 1174 my ($l, $r) = %{$fin_idx->{$_}}; 1175 1176 if ( 1177 ref $r eq 'ARRAY' 1178 and 1179 ( 1180 ( @$r == 1 and $l =~ /^\-and$/i ) 1181 or 1182 $l =~ /^\-or$/i 1183 ) 1184 ) { 1185 push @or, @$r 1186 } 1187 1188 elsif ( 1189 ref $r eq 'HASH' 1190 and 1191 keys %$r == 1 1192 and 1193 $l =~ /^\-(?:and|or)$/i 1194 ) { 1195 push @or, %$r; 1196 } 1197 1198 else { 1199 push @or, $l, $r; 1200 } 1201 } 1202 else { 1203 push @or, $fin_idx->{$_}; 1204 } 1205 } 1206 1207 $fin->{-or} = \@or; 1208 } 1209 } 1210 else { 1211 # not a hash not an array 1212 $fin = { -and => [ $where ] }; 1213 } 1214 1215 # unroll single-element -and's 1216 while ( 1217 $fin->{-and} 1218 and 1219 @{$fin->{-and}} < 2 1220 ) { 1221 my $and = delete $fin->{-and}; 1222 last if @$and == 0; 1223 1224 # at this point we have @$and == 1 1225 if ( 1226 ref $and->[0] eq 'HASH' 1227 and 1228 ! grep { exists $fin->{$_} } keys %{$and->[0]} 1229 ) { 1230 $fin = { 1231 %$fin, %{$and->[0]} 1232 }; 1233 } 1234 else { 1235 $fin->{-and} = $and; 1236 last; 1237 } 1238 } 1239 1240 # compress same-column conds found in $fin 1241 for my $col ( grep { $_ !~ /^\-/ } keys %$fin ) { 1242 next unless ref $fin->{$col} eq 'ARRAY' and ($fin->{$col}[0]||'') =~ /^\-and$/i; 1243 my $val_bag = { map { 1244 (! defined $_ ) ? ( UNDEF => undef ) 1245 : ( ! length ref $_ or is_plain_value $_ ) ? ( "VAL_$_" => $_ ) 1246 : ( ( 'SER_' . serialize $_ ) => $_ ) 1247 } @{$fin->{$col}}[1 .. $#{$fin->{$col}}] }; 1248 1249 if (keys %$val_bag == 1 ) { 1250 ($fin->{$col}) = values %$val_bag; 1251 } 1252 else { 1253 $fin->{$col} = [ -and => map { $val_bag->{$_} } sort keys %$val_bag ]; 1254 } 1255 } 1256 1257 return keys %$fin ? $fin : (); 1258} 1259 1260sub _collapse_cond_unroll_pairs { 1261 my ($self, $pairs) = @_; 1262 1263 my @conds; 1264 1265 while (@$pairs) { 1266 my ($lhs, $rhs) = splice @$pairs, 0, 2; 1267 1268 if ($lhs eq '') { 1269 push @conds, $self->_collapse_cond($rhs); 1270 } 1271 elsif ( $lhs =~ /^\-and$/i ) { 1272 push @conds, $self->_collapse_cond($rhs, (ref $rhs eq 'ARRAY')); 1273 } 1274 elsif ( $lhs =~ /^\-or$/i ) { 1275 push @conds, $self->_collapse_cond( 1276 (ref $rhs eq 'HASH') ? [ map { $_ => $rhs->{$_} } sort keys %$rhs ] : $rhs 1277 ); 1278 } 1279 else { 1280 if (ref $rhs eq 'HASH' and ! keys %$rhs) { 1281 # FIXME - SQLAC seems to be doing... nothing...? 1282 } 1283 # normalize top level -ident, for saner extract_fixed_condition_columns code 1284 elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{-ident}) { 1285 push @conds, { $lhs => { '=', $rhs } }; 1286 } 1287 # can't simply use is_plain_value result, as we need to 1288 # preserve the -value marker where necessary (non-blessed ref) 1289 elsif ( 1290 ref $rhs eq 'HASH' 1291 and 1292 keys %$rhs == 1 1293 and 1294 exists $rhs->{-value} 1295 and 1296 ( 1297 ! length ref( $rhs->{-value} ) 1298 or 1299 ( 1300 defined( blessed $rhs->{-value} ) 1301 and 1302 is_plain_value $rhs->{-value} 1303 ) 1304 ) 1305 ) { 1306 push @conds, { $lhs => $rhs->{-value} }; 1307 } 1308 elsif (ref $rhs eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='}) { 1309 if ( length ref $rhs->{'='} and is_literal_value $rhs->{'='} ) { 1310 push @conds, { $lhs => $rhs }; 1311 } 1312 else { 1313 for my $p ($self->_collapse_cond_unroll_pairs([ $lhs => $rhs->{'='} ])) { 1314 1315 # extra sanity check 1316 if (keys %$p > 1) { 1317 require Data::Dumper::Concise; 1318 local $Data::Dumper::Deepcopy = 1; 1319 $self->throw_exception( 1320 "Internal error: unexpected collapse unroll:" 1321 . Data::Dumper::Concise::Dumper { in => { $lhs => $rhs }, out => $p } 1322 ); 1323 } 1324 1325 my ($l, $r) = %$p; 1326 1327 push @conds, ( 1328 ! length ref $r 1329 or 1330 # the unroller recursion may return a '=' prepended value already 1331 ref $r eq 'HASH' and keys %$rhs == 1 and exists $rhs->{'='} 1332 or 1333 is_plain_value($r) 1334 ) 1335 ? { $l => $r } 1336 : { $l => { '=' => $r } } 1337 ; 1338 } 1339 } 1340 } 1341 elsif (ref $rhs eq 'ARRAY') { 1342 # some of these conditionals encounter multi-values - roll them out using 1343 # an unshift, which will cause extra looping in the while{} above 1344 if (! @$rhs ) { 1345 push @conds, { $lhs => [] }; 1346 } 1347 elsif ( ($rhs->[0]||'') =~ /^\-(?:and|or)$/i ) { 1348 $self->throw_exception("Value modifier not followed by any values: $lhs => [ $rhs->[0] ] ") 1349 if @$rhs == 1; 1350 1351 if( $rhs->[0] =~ /^\-and$/i ) { 1352 unshift @$pairs, map { $lhs => $_ } @{$rhs}[1..$#$rhs]; 1353 } 1354 # if not an AND then it's an OR 1355 elsif(@$rhs == 2) { 1356 unshift @$pairs, $lhs => $rhs->[1]; 1357 } 1358 else { 1359 push @conds, { $lhs => [ @{$rhs}[1..$#$rhs] ] }; 1360 } 1361 } 1362 elsif (@$rhs == 1) { 1363 unshift @$pairs, $lhs => $rhs->[0]; 1364 } 1365 else { 1366 push @conds, { $lhs => $rhs }; 1367 } 1368 } 1369 # unroll func + { -value => ... } 1370 # can't simply use is_plain_value result, as we need to 1371 # preserve the -value marker where necessary (non-blessed ref) 1372 elsif ( 1373 ref $rhs eq 'HASH' 1374 and 1375 ( my ($subop) = keys %$rhs ) == 1 1376 and 1377 ref( (values %$rhs)[0] ) eq 'HASH' 1378 and 1379 keys %{ (values %$rhs)[0] } == 1 1380 and 1381 exists( (values %$rhs)[0]->{-value} ) 1382 and 1383 ( 1384 ! length ref( (values %$rhs)[0]->{-value} ) 1385 or 1386 ( 1387 defined( blessed( (values %$rhs)[0]->{-value} ) ) 1388 and 1389 is_plain_value( (values %$rhs)[0]->{-value} ) 1390 ) 1391 ) 1392 ) { 1393 push @conds, { $lhs => { $subop => (values %$rhs)[0]->{-value} } }; 1394 } 1395 else { 1396 push @conds, { $lhs => $rhs }; 1397 } 1398 } 1399 } 1400 1401 return @conds; 1402} 1403 1404# Analyzes a given condition and attempts to extract all columns 1405# with a definitive fixed-condition criteria. Returns a hashref 1406# of k/v pairs suitable to be passed to set_columns(), with a 1407# MAJOR CAVEAT - multi-value (contradictory) equalities are still 1408# represented as a reference to the UNRESOVABLE_CONDITION constant 1409# The reason we do this is that some codepaths only care about the 1410# codition being stable, as opposed to actually making sense 1411# 1412# The normal mode is used to figure out if a resultset is constrained 1413# to a column which is part of a unique constraint, which in turn 1414# allows us to better predict how ordering will behave etc. 1415# 1416# With the optional "consider_nulls" boolean argument, the function 1417# is instead used to infer inambiguous values from conditions 1418# (e.g. the inheritance of resultset conditions on new_result) 1419# 1420sub _extract_fixed_condition_columns { 1421 my ($self, $where, $consider_nulls) = @_; 1422 my $where_hash = $self->_collapse_cond($_[1]); 1423 1424 my $res = {}; 1425 my ($c, $v); 1426 for $c (keys %$where_hash) { 1427 my $vals; 1428 1429 if (!defined ($v = $where_hash->{$c}) ) { 1430 $vals->{UNDEF} = $v if $consider_nulls 1431 } 1432 elsif ( 1433 ref $v eq 'HASH' 1434 and 1435 keys %$v == 1 1436 ) { 1437 if (exists $v->{-value}) { 1438 if (defined $v->{-value}) { 1439 $vals->{"VAL_$v->{-value}"} = $v->{-value} 1440 } 1441 elsif( $consider_nulls ) { 1442 $vals->{UNDEF} = $v->{-value}; 1443 } 1444 } 1445 # do not need to check for plain values - _collapse_cond did it for us 1446 elsif( 1447 length ref $v->{'='} 1448 and 1449 ( 1450 ( ref $v->{'='} eq 'HASH' and keys %{$v->{'='}} == 1 and exists $v->{'='}{-ident} ) 1451 or 1452 is_literal_value($v->{'='}) 1453 ) 1454 ) { 1455 $vals->{ 'SER_' . serialize $v->{'='} } = $v->{'='}; 1456 } 1457 } 1458 elsif ( 1459 ! length ref $v 1460 or 1461 is_plain_value ($v) 1462 ) { 1463 $vals->{"VAL_$v"} = $v; 1464 } 1465 elsif (ref $v eq 'ARRAY' and ($v->[0]||'') eq '-and') { 1466 for ( @{$v}[1..$#$v] ) { 1467 my $subval = $self->_extract_fixed_condition_columns({ $c => $_ }, 'consider nulls'); # always fish nulls out on recursion 1468 next unless exists $subval->{$c}; # didn't find anything 1469 $vals->{ 1470 ! defined $subval->{$c} ? 'UNDEF' 1471 : ( ! length ref $subval->{$c} or is_plain_value $subval->{$c} ) ? "VAL_$subval->{$c}" 1472 : ( 'SER_' . serialize $subval->{$c} ) 1473 } = $subval->{$c}; 1474 } 1475 } 1476 1477 if (keys %$vals == 1) { 1478 ($res->{$c}) = (values %$vals) 1479 unless !$consider_nulls and exists $vals->{UNDEF}; 1480 } 1481 elsif (keys %$vals > 1) { 1482 $res->{$c} = UNRESOLVABLE_CONDITION; 1483 } 1484 } 1485 1486 $res; 1487} 1488 14891; 1490