File Coverage

blib/lib/DBIx/Class/Storage/DBIHacks.pm
Criterion Covered Total %
statement 330 350 94.2
branch 138 160 86.2
condition 107 145 73.7
subroutine 26 32 81.2
pod n/a
total 601 687 87.4


line stmt bran cond sub pod time code
1             package #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-sight-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 2015), more than 6 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              
25 233     233   1786 use strict;
  233         599  
  233         6609  
26 233     233   1283 use warnings;
  233         523  
  233         6185  
27              
28 233     233   1225 use base 'DBIx::Class::Storage';
  233         527  
  233         92018  
29 233     233   1917 use mro 'c3';
  233         551  
  233         1584  
30              
31 233     233   6696 use Scalar::Util 'blessed';
  233         554  
  233         11807  
32 233         10197 use DBIx::Class::_Util qw(
33             dump_value fail_on_internal_call
34 233     233   1409 );
  233         492  
35 233     233   2091 use DBIx::Class::SQLMaker::Util 'extract_equality_conditions';
  233         515  
  233         11300  
36 233         11463 use DBIx::Class::ResultSource::FromSpec::Util qw(
37             fromspec_columns_info
38             find_join_path_to_alias
39 233     233   2095 );
  233         555  
40 233     233   1532 use DBIx::Class::Carp;
  233         510  
  233         1256  
41 233     233   1337 use namespace::clean;
  233         545  
  233         1121  
42              
43             #
44             # This code will remove non-selecting/non-restricting joins from
45             # {from} specs, aiding the RDBMS query optimizer
46             #
47             sub _prune_unused_joins {
48 992     992   2984 my ($self, $attrs) = @_;
49              
50             # only standard {from} specs are supported, and we could be disabled in general
51             return ($attrs->{from}, {}) unless (
52             ref $attrs->{from} eq 'ARRAY'
53             and
54 992         33636 @{$attrs->{from}} > 1
55             and
56             ref $attrs->{from}[0] eq 'HASH'
57             and
58 992 100 33     4730 ref $attrs->{from}[1] eq 'ARRAY'
      33        
      33        
      66        
59             and
60             $self->_use_join_optimizer
61             );
62              
63             my $orig_aliastypes =
64             $attrs->{_precalculated_aliastypes}
65             ||
66 935   66     9970 $self->_resolve_aliastypes_from_select_args($attrs)
67             ;
68              
69 935         4351 my $new_aliastypes = { %$orig_aliastypes };
70              
71             # we will be recreating this entirely
72 935         3301 my @reclassify = 'joining';
73              
74             # a grouped set will not be affected by amount of rows. Thus any
75             # purely multiplicator classifications can go
76             # (will be reintroduced below if needed by something else)
77             push @reclassify, qw(multiplying premultiplied)
78 935 100 100     6031 if $attrs->{_force_prune_multiplying_joins} or $attrs->{group_by};
79              
80             # nuke what will be recalculated
81 935         2100 delete @{$new_aliastypes}{@reclassify};
  935         2793  
82              
83 935         3369 my @newfrom = $attrs->{from}[0]; # FROM head is always present
84              
85             # recalculate what we need once the multipliers are potentially gone
86             # ignore premultiplies, since they do not add any value to anything
87 935         1923 my %need_joins;
88 935         3716 for ( @{$new_aliastypes}{grep { $_ ne 'premultiplied' } keys %$new_aliastypes }) {
  935         3013  
  2685         6544  
89             # add all requested aliases
90 2505         8129 $need_joins{$_} = 1 for keys %$_;
91              
92             # add all their parents (as per joinpath which is an AoH { table => alias })
93 2505         5776 $need_joins{$_} = 1 for map { values %$_ } map { @{$_->{-parents}} } values %$_;
  3581         10201  
  4282         6014  
  4282         9065  
94             }
95              
96 935         2708 for my $j (@{$attrs->{from}}[1..$#{$attrs->{from}}]) {
  935         2763  
  935         2695  
97             push @newfrom, $j if (
98             (! defined $j->[0]{-alias}) # legacy crap
99             ||
100             $need_joins{$j->[0]{-alias}}
101 1615 100 100     9139 );
102             }
103              
104             # we have a new set of joiners - for everything we nuked pull the classification
105             # off the original stack
106 935         2714 for my $ctype (@reclassify) {
107             $new_aliastypes->{$ctype} = { map
108 2838 100       10079 { $need_joins{$_} ? ( $_ => $orig_aliastypes->{$ctype}{$_} ) : () }
109 1409         2514 keys %{$orig_aliastypes->{$ctype}}
  1409         4203  
110             }
111             }
112              
113 935         7381 return ( \@newfrom, $new_aliastypes );
114             }
115              
116             #
117             # This is the code producing joined subqueries like:
118             # SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ...
119             #
120             sub _adjust_select_args_for_complex_prefetch {
121 87     87   261 my ($self, $attrs) = @_;
122              
123             $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute') unless (
124             ref $attrs->{from} eq 'ARRAY'
125             and
126 87         823 @{$attrs->{from}} > 1
127             and
128             ref $attrs->{from}[0] eq 'HASH'
129             and
130 87 50 33     426 ref $attrs->{from}[1] eq 'ARRAY'
      33        
      33        
131             );
132              
133 87         232 my $root_alias = $attrs->{alias};
134              
135             # generate inner/outer attribute lists, remove stuff that doesn't apply
136 87         671 my $outer_attrs = { %$attrs };
137 87         249 delete @{$outer_attrs}{qw(from bind rows offset group_by _grouped_by_distinct having)};
  87         365  
138              
139 87         535 my $inner_attrs = { %$attrs, _simple_passthrough_construction => 1 };
140 87         292 delete @{$inner_attrs}{qw(for collapse select as)};
  87         232  
141              
142             # there is no point of ordering the insides if there is no limit
143             delete $inner_attrs->{order_by} if (
144             delete $inner_attrs->{_order_is_artificial}
145             or
146             ! $inner_attrs->{rows}
147 87 100 100     481 );
148              
149             # generate the inner/outer select lists
150             # for inside we consider only stuff *not* brought in by the prefetch
151             # on the outside we substitute any function for its alias
152 87         178 $outer_attrs->{select} = [ @{$attrs->{select}} ];
  87         342  
153              
154 87         207 my ($root_node, $root_node_offset);
155              
156 87         172 for my $i (0 .. $#{$inner_attrs->{from}}) {
  87         360  
157 107         227 my $node = $inner_attrs->{from}[$i];
158 107 50 33     386 my $h = (ref $node eq 'HASH') ? $node
    100          
159             : (ref $node eq 'ARRAY' and ref $node->[0] eq 'HASH') ? $node->[0]
160             : next
161             ;
162              
163 107 50 50     639 if ( ($h->{-alias}||'') eq $root_alias and $h->{-rsrc} ) {
      66        
164 87         169 $root_node = $h;
165 87         184 $root_node_offset = $i;
166 87         198 last;
167             }
168             }
169              
170 87 50       252 $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute')
171             unless $root_node;
172              
173             # use the heavy duty resolver to take care of aliased/nonaliased naming
174 87         393 my $colinfo = fromspec_columns_info($inner_attrs->{from});
175 87         197 my $selected_root_columns;
176              
177 87         183 for my $i (0 .. $#{$outer_attrs->{select}}) {
  87         345  
178 754         1175 my $sel = $outer_attrs->{select}->[$i];
179              
180             next if (
181 754 100 100     2550 $colinfo->{$sel} and $colinfo->{$sel}{-source_alias} ne $root_alias
182             );
183              
184 322 100 66     1291 if (ref $sel eq 'HASH' ) {
    100          
185 17   66     58 $sel->{-as} ||= $attrs->{as}[$i];
186 17   33     66 $outer_attrs->{select}->[$i] = join ('.', $root_alias, ($sel->{-as} || "inner_column_$i") );
187             }
188             elsif (! ref $sel and my $ci = $colinfo->{$sel}) {
189 295         599 $selected_root_columns->{$ci->{-colname}} = 1;
190             }
191              
192 322         457 push @{$inner_attrs->{select}}, $sel;
  322         629  
193              
194 322         488 push @{$inner_attrs->{as}}, $attrs->{as}[$i];
  322         767  
195             }
196              
197 87         381 my $inner_aliastypes = $self->_resolve_aliastypes_from_select_args($inner_attrs);
198              
199             # In the inner subq we will need to fetch *only* native columns which may
200             # be a part of an *outer* join condition, or an order_by (which needs to be
201             # preserved outside), or wheres. In other words everything but the inner
202             # selector
203             # We can not just fetch everything because a potential has_many restricting
204             # join collapse *will not work* on heavy data types.
205              
206             # essentially a map of all non-selecting seen columns
207             # the sort is there for a nicer select list
208 87         356 for (
209             sort
210             map
211 619 100       808 { keys %{$_->{-seen_columns}||{}} }
  619         2196  
212             map
213 352         483 { values %{$inner_aliastypes->{$_}} }
  352         813  
214             grep
215 435         899 { $_ ne 'selecting' }
216             keys %$inner_aliastypes
217             ) {
218 546 50       1037 my $ci = $colinfo->{$_} or next;
219 546 100 100     1761 if (
220             $ci->{-source_alias} eq $root_alias
221             and
222             ! $selected_root_columns->{$ci->{-colname}}++
223             ) {
224             # adding it to both to keep limits not supporting dark selectors happy
225 37         75 push @{$inner_attrs->{select}}, $ci->{-fq_colname};
  37         123  
226 37         79 push @{$inner_attrs->{as}}, $ci->{-fq_colname};
  37         122  
227             }
228             }
229              
230             # construct the inner {from} and lock it in a subquery
231             # we need to prune first, because this will determine if we need a group_by below
232             # throw away all non-selecting, non-restricting multijoins
233             # (since we def. do not care about multiplication of the contents of the subquery)
234 87         244 my $inner_subq = do {
235              
236             # must use it here regardless of user requests (vastly gentler on optimizer)
237             local $self->{_use_join_optimizer} = 1
238 87 50       399 unless $self->{_use_join_optimizer};
239              
240             # throw away multijoins since we def. do not care about those inside the subquery
241             # $inner_aliastypes *will* be redefined at this point
242 87         1120 ($inner_attrs->{from}, $inner_aliastypes ) = $self->_prune_unused_joins ({
243             %$inner_attrs,
244             _force_prune_multiplying_joins => 1,
245             _precalculated_aliastypes => $inner_aliastypes,
246             });
247              
248             # uh-oh a multiplier (which is not us) left in, this is a problem for limits
249             # we will need to add a group_by to collapse the resultset for proper counts
250 87 100 100     521 if (
      100        
251 64 50       359 grep { $_ ne $root_alias } keys %{ $inner_aliastypes->{multiplying} || {} }
  87         470  
252             and
253             # if there are user-supplied groups - assume user knows wtf they are up to
254             ( ! $inner_aliastypes->{grouping} or $inner_attrs->{_grouped_by_distinct} )
255             ) {
256              
257 39         77 my $cur_sel = { map { $_ => 1 } @{$inner_attrs->{select}} };
  195         371  
  39         98  
258              
259             # *possibly* supplement the main selection with pks if not already
260             # there, as they will have to be a part of the group_by to collapse
261             # things properly
262 39         97 my $inner_select_with_extras;
263 39         235 my @pks = map { "$root_alias.$_" } $root_node->{-rsrc}->primary_columns
264             or $self->throw_exception( sprintf
265             'Unable to perform complex limited prefetch off %s without declared primary key',
266             $root_node->{-rsrc}->source_name,
267 39 50       881 );
268 39         117 for my $col (@pks) {
269 0   0     0 push @{ $inner_select_with_extras ||= [ @{$inner_attrs->{select}} ] }, $col
  0         0  
270 39 50       138 unless $cur_sel->{$col}++;
271             }
272              
273 39 50       487 ($inner_attrs->{group_by}, $inner_attrs->{order_by}) = $self->_group_over_selection({
274             %$inner_attrs,
275             $inner_select_with_extras ? ( select => $inner_select_with_extras ) : (),
276             _aliastypes => $inner_aliastypes,
277             });
278             }
279              
280             # we already optimized $inner_attrs->{from} above
281             # and already local()ized
282 86         327 $self->{_use_join_optimizer} = 0;
283              
284             # generate the subquery
285             $self->_select_args_to_query (
286 86         229 @{$inner_attrs}{qw(from select where)},
  86         436  
287             $inner_attrs,
288             );
289             };
290              
291             # Generate the outer from - this is relatively easy (really just replace
292             # the join slot with the subquery), with a major caveat - we can not
293             # join anything that is non-selecting (not part of the prefetch), but at
294             # the same time is a multi-type relationship, as it will explode the result.
295             #
296             # There are two possibilities here
297             # - either the join is non-restricting, in which case we simply throw it away
298             # - it is part of the restrictions, in which case we need to collapse the outer
299             # result by tackling yet another group_by to the outside of the query
300              
301             # work on a shallow copy
302 86         234 my @orig_from = @{$attrs->{from}};
  86         301  
303              
304              
305 86         247 $outer_attrs->{from} = \ my @outer_from;
306              
307             # we may not be the head
308 86 100       298 if ($root_node_offset) {
309             # first generate the outer_from, up to the substitution point
310 17         53 @outer_from = splice @orig_from, 0, $root_node_offset;
311              
312             # substitute the subq at the right spot
313             push @outer_from, [
314             {
315             -alias => $root_alias,
316             -rsrc => $root_node->{-rsrc},
317             $root_alias => $inner_subq,
318             },
319             # preserve attrs from what is now the head of the from after the splice
320 17         82 @{$orig_from[0]}[1 .. $#{$orig_from[0]}],
  17         44  
  17         48  
321             ];
322             }
323             else {
324             @outer_from = {
325             -alias => $root_alias,
326             -rsrc => $root_node->{-rsrc},
327 69         330 $root_alias => $inner_subq,
328             };
329             }
330              
331 86         192 shift @orig_from; # what we just replaced above
332              
333             # scan the *remaining* from spec against different attributes, and see which joins are needed
334             # in what role
335             my $outer_aliastypes = $outer_attrs->{_aliastypes} =
336 86         791 $self->_resolve_aliastypes_from_select_args({ %$outer_attrs, from => \@orig_from });
337              
338             # unroll parents
339 86         450 my ($outer_select_chain, @outer_nonselecting_chains) = map { +{
340 344 100       541 map { $_ => 1 } map { values %$_} map { @{$_->{-parents}} } values %{ $outer_aliastypes->{$_} || {} }
  273         734  
  273         599  
  186         285  
  186         473  
  344         1365  
341             } } qw/selecting restricting grouping ordering/;
342              
343             # see what's left - throw away if not selecting/restricting
344 86         219 my $may_need_outer_group_by;
345 86         345 while (my $j = shift @orig_from) {
346 119         283 my $alias = $j->[0]{-alias};
347              
348 119 100       322 if (
    100          
349             $outer_select_chain->{$alias}
350             ) {
351 109         2749 push @outer_from, $j
352             }
353 30         58 elsif (grep { $_->{$alias} } @outer_nonselecting_chains ) {
354 8         15 push @outer_from, $j;
355 8 100 66     42 $may_need_outer_group_by ||= $outer_aliastypes->{multiplying}{$alias} ? 1 : 0;
356             }
357             }
358              
359             # also throw in a synthetic group_by if a non-selecting multiplier,
360             # to guard against cross-join explosions
361             # the logic is somewhat fragile, but relies on the idea that if a user supplied
362             # a group by on their own - they know what they were doing
363 86 100 100     304 if ( $may_need_outer_group_by and $attrs->{_grouped_by_distinct} ) {
364 2         16 ($outer_attrs->{group_by}, $outer_attrs->{order_by}) = $self->_group_over_selection ({
365             %$outer_attrs,
366             from => \@outer_from,
367             });
368             }
369              
370             # FIXME: The {where} ends up in both the inner and outer query, i.e. *twice*
371             #
372             # This is rather horrific, and while we currently *do* have enough
373             # introspection tooling available to attempt a stab at properly deciding
374             # whether or not to include the where condition on the outside, the
375             # machinery is still too slow to apply it here.
376             # Thus for the time being we do not attempt any sanitation of the where
377             # clause and just pass it through on both sides of the subquery. This *will*
378             # be addressed at a later stage, most likely after folding the SQL generator
379             # into SQLMaker proper
380             #
381             # OTOH it can be seen as a plus: (notes that this query would make a DBA cry ;)
382             #
383 86         2565 return $outer_attrs;
384             }
385              
386             # This is probably the ickiest, yet most relied upon part of the codebase:
387             # this is the place where we take arbitrary SQL input and break it into its
388             # constituent parts, making sure we know which *sources* are used in what
389             # *capacity* ( selecting / restricting / grouping / ordering / joining, etc )
390             # Although the method is pretty horrific, the worst thing that can happen is
391             # for a classification failure, which in turn will result in a vocal exception,
392             # and will lead to a relatively prompt fix.
393             # The code has been slowly improving and is covered with a formiddable battery
394             # of tests, so can be considered "reliably stable" at this point (Oct 2015).
395             #
396             # A note to implementors attempting to "replace" this - keep in mind that while
397             # there are multiple optimization avenues, the actual "scan literal elements"
398             # part *MAY NEVER BE REMOVED*, even if it is limited only ot the (future) AST
399             # nodes that are deemed opaque (i.e. contain literal expressions). The use of
400             # blackbox literals is at this point firmly a user-facing API, and is one of
401             # *the* reasons DBIC remains as flexible as it is. In other words, when working
402             # on this keep in mind that the following is widespread and *encouraged* way
403             # of using DBIC in the wild when push comes to shove:
404             #
405             # $rs->search( {}, {
406             # select => \[ $random, @stuff],
407             # from => \[ $random, @stuff ],
408             # where => \[ $random, @stuff ],
409             # group_by => \[ $random, @stuff ],
410             # order_by => \[ $random, @stuff ],
411             # } )
412             #
413             # Various incarnations of the above are reflected in many of the tests. If one
414             # gets to fail, you get to fix it. A "this is crazy, nobody does that" is not
415             # acceptable going forward.
416             #
417             sub _resolve_aliastypes_from_select_args {
418 1076     1076   3216 my ( $self, $attrs ) = @_;
419              
420             $self->throw_exception ('Unable to analyze custom {from}')
421 1076 50       4551 if ref $attrs->{from} ne 'ARRAY';
422              
423             # what we will return
424 1076         2683 my $aliases_by_type;
425              
426             # see what aliases are there to work with
427             # and record who is a multiplier and who is premultiplied
428             my $alias_list;
429 1076         2126 for my $node (@{$attrs->{from}}) {
  1076         3416  
430              
431 2788         4876 my $j = $node;
432 2788 100       7760 $j = $j->[0] if ref $j eq 'ARRAY';
433             my $al = $j->{-alias}
434 2788 100       7679 or next;
435              
436 2780         6322 $alias_list->{$al} = $j;
437              
438             $aliases_by_type->{multiplying}{$al} ||= { -parents => $j->{-join_path}||[] }
439             # not array == {from} head == can't be multiplying
440 2780 100 50     15860 if ref($node) eq 'ARRAY' and ! $j->{-is_single};
      50        
      100        
441              
442             $aliases_by_type->{premultiplied}{$al} ||= { -parents => $j->{-join_path}||[] }
443             # parts of the path that are not us but are multiplying
444 830         4559 if grep { $aliases_by_type->{multiplying}{$_} }
445 2624         8336 grep { $_ ne $al }
446 2624         8235 map { values %$_ }
447 2780 100 50     4760 @{ $j->{-join_path}||[] }
  2780 100 50     11531  
448             }
449              
450             # get a column to source/alias map (including unambiguous unqualified ones)
451 1076         5502 my $colinfo = fromspec_columns_info($attrs->{from});
452              
453             # set up a botched SQLA
454 1076         28458 my $sql_maker = $self->sql_maker;
455              
456             # these are throw away results, do not pollute the bind stack
457 1076         3378 local $sql_maker->{where_bind};
458 1076         4880 local $sql_maker->{group_bind};
459 1076         2781 local $sql_maker->{having_bind};
460 1076         2585 local $sql_maker->{from_bind};
461              
462             # we can't scan properly without any quoting (\b doesn't cut it
463             # everywhere), so unless there is proper quoting set - use our
464             # own weird impossible character.
465             # Also in the case of no quoting, we need to explicitly disable
466             # name_sep, otherwise sorry nasty legacy syntax like
467             # { 'count(foo.id)' => { '>' => 3 } } will stop working >:(
468 1076         3314 local $sql_maker->{quote_char} = $sql_maker->{quote_char};
469 1076         5096 local $sql_maker->{name_sep} = $sql_maker->{name_sep};
470              
471 1076 100 66     4516 unless (defined $sql_maker->{quote_char} and length $sql_maker->{quote_char}) {
472 977         3131 $sql_maker->{quote_char} = ["\x00", "\xFF"];
473             # if we don't unset it we screw up retarded but unfortunately working
474             # 'MAX(foo.bar)' => { '>', 3 }
475 977         2470 $sql_maker->{name_sep} = '';
476             }
477              
478 1076         5502 my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep);
  3228         21540  
479              
480             # generate sql chunks
481             my $to_scan = {
482             restricting => [
483             ($sql_maker->_recurse_where ($attrs->{where}))[0],
484             $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} }),
485             ],
486             grouping => [
487             $sql_maker->_parse_rs_attrs ({ group_by => $attrs->{group_by} }),
488             ],
489             joining => [
490             $sql_maker->_recurse_from (
491             ref $attrs->{from}[0] eq 'ARRAY' ? $attrs->{from}[0][0] : $attrs->{from}[0],
492 1076         4913 @{$attrs->{from}}[1 .. $#{$attrs->{from}}],
  1076         3230  
493             ),
494             ],
495             selecting => [
496             # kill all selectors which look like a proper subquery
497             # this is a sucky heuristic *BUT* - if we get it wrong the query will simply
498             # fail to run, so we are relatively safe
499             grep
500 5395         36900 { $_ !~ / \A \s* \( \s* SELECT \s+ .+? \s+ FROM \s+ .+? \) \s* \z /xsi }
501             map
502             {
503 5395 100       118862 length ref $_
504             ? ($sql_maker->_recurse_fields($_))[0]
505             : $sql_maker->_quote($_)
506             }
507 1076         3940 @{$attrs->{select}}
508             ],
509             ordering => [ map
510             {
511 716 100       26746 ( my $sql = (ref $_ ? $_->[0] : $_) ) =~ s/ \s+ (?: ASC | DESC ) \s* \z //xi;
512 716         3060 $sql;
513             }
514 1076 100       6806 $sql_maker->_order_by_chunks( $attrs->{order_by} ),
515             ],
516             };
517              
518             # we will be bulk-scanning anyway - pieces will not matter in that case,
519             # thus join everything up
520             # throw away empty-string chunks, and make sure no binds snuck in
521             # note that we operate over @{$to_scan->{$type}}, hence the
522             # semi-mindbending ... map ... for values ...
523             ( $_ = join ' ', map {
524              
525 10385 100       47729 ( ! defined $_ ) ? ()
    50          
    100          
526             : ( length ref $_ ) ? $self->throw_exception(
527             "Unexpected ref in scan-plan: " . dump_value $_
528             )
529             : ( $_ =~ /^\s*$/ ) ? ()
530             : $_
531              
532 1076         52500 } @$_ ) for values %$to_scan;
533              
534             # throw away empty to-scan's
535             (
536             length $to_scan->{$_}
537             or
538             delete $to_scan->{$_}
539 1076   66     9319 ) for keys %$to_scan;
540              
541              
542              
543             # these will be used for matching in the loop below
544 1076         4493 my $all_aliases = join ' | ', map { quotemeta $_ } keys %$alias_list;
  2780         7243  
545 1076         65883 my $fq_col_re = qr/
546             $lquote ( $all_aliases ) $rquote $sep (?: $lquote ([^$rquote]+) $rquote )?
547             |
548             \b ( $all_aliases ) \. ( [^\s\)\($rquote]+ )?
549             /x;
550              
551              
552             my $all_unq_columns = join ' | ',
553             map
554 8865         17204 { quotemeta $_ }
555             grep
556             # using a regex here shows up on profiles, boggle
557 1076         8616 { index( $_, '.') < 0 }
  20831         38410  
558             keys %$colinfo
559             ;
560 1076 100       81937 my $unq_col_re = $all_unq_columns
561             ? qr/
562             $lquote ( $all_unq_columns ) $rquote
563             |
564             (?: \A | \s ) ( $all_unq_columns ) (?: \s | \z )
565             /x
566             : undef
567             ;
568              
569              
570             # the actual scan, per type
571 1076         6297 for my $type (keys %$to_scan) {
572              
573              
574             # now loop through all fully qualified columns and get the corresponding
575             # alias (should work even if they are in scalarrefs)
576             #
577             # The regex captures in multiples of 4, with one of the two pairs being
578             # undef. There may be a *lot* of matches, hence the convoluted loop
579 3314         51788 my @matches = $to_scan->{$type} =~ /$fq_col_re/g;
580 3314         7433 my $i = 0;
581 3314         8594 while( $i < $#matches ) {
582              
583 16547 100       31920 if (
584             defined $matches[$i]
585             ) {
586 12685   100     52638 $aliases_by_type->{$type}{$matches[$i]} ||= { -parents => $alias_list->{$matches[$i]}{-join_path}||[] };
      100        
587              
588 12685 100       45796 $aliases_by_type->{$type}{$matches[$i]}{-seen_columns}{"$matches[$i].$matches[$i+1]"} = "$matches[$i].$matches[$i+1]"
589             if defined $matches[$i+1];
590              
591 12685         20153 $i += 2;
592             }
593              
594 16547         30119 $i += 2;
595             }
596              
597              
598             # now loop through unqualified column names, and try to locate them within
599             # the chunks, if there are any unqualified columns in the 1st place
600 3314 100       7611 next unless $unq_col_re;
601              
602             # The regex captures in multiples of 2, one of the two being undef
603 3278         60399 for ( $to_scan->{$type} =~ /$unq_col_re/g ) {
604 4992 100       11849 defined $_ or next;
605 2496 50       6315 my $alias = $colinfo->{$_}{-source_alias} or next;
606 2496   100     7040 $aliases_by_type->{$type}{$alias} ||= { -parents => $alias_list->{$alias}{-join_path}||[] };
      100        
607 2496         11432 $aliases_by_type->{$type}{$alias}{-seen_columns}{"$alias.$_"} = $_
608             }
609             }
610              
611              
612             # Add any non-left joins to the restriction list (such joins are indeed restrictions)
613             (
614             $_->{-alias}
615             and
616             ! $aliases_by_type->{restricting}{ $_->{-alias} }
617             and
618             (
619             not $_->{-join_type}
620             or
621             $_->{-join_type} !~ /^left (?: \s+ outer)? $/xi
622             )
623             and
624             $aliases_by_type->{restricting}{ $_->{-alias} } = { -parents => $_->{-join_path}||[] }
625 1076   100     24052 ) for values %$alias_list;
      100        
      100        
      100        
      100        
626              
627              
628             # final cleanup
629             (
630 4425         16569 keys %{$aliases_by_type->{$_}}
631             or
632             delete $aliases_by_type->{$_}
633 1076   66     4795 ) for keys %$aliases_by_type;
634              
635              
636 1076         25153 $aliases_by_type;
637             }
638              
639             # This is the engine behind { distinct => 1 } and the general
640             # complex prefetch grouper
641             sub _group_over_selection {
642 110     110   1682 my ($self, $attrs) = @_;
643              
644 110         647 my $colinfos = fromspec_columns_info($attrs->{from});
645              
646 110         316 my (@group_by, %group_index);
647              
648             # the logic is: if it is a { func => val } we assume an aggregate,
649             # otherwise if \'...' or \[...] we assume the user knows what is
650             # going on thus group over it
651 110         237 for (@{$attrs->{select}}) {
  110         380  
652 413 100 100     1138 if (! ref($_) or ref ($_) ne 'HASH' ) {
653 399         786 push @group_by, $_;
654 399         771 $group_index{$_}++;
655 399 50 66     1797 if ($colinfos->{$_} and $_ !~ /\./ ) {
656             # add a fully qualified version as well
657 0         0 $group_index{"$colinfos->{$_}{-source_alias}.$_"}++;
658             }
659             }
660             }
661              
662             my @order_by = $self->_extract_order_criteria($attrs->{order_by})
663 110 100       672 or return (\@group_by, $attrs->{order_by});
664              
665             # add any order_by parts that are not already present in the group_by
666             # to maintain SQL cross-compatibility and general sanity
667             #
668             # also in case the original selection is *not* unique, or in case part
669             # of the ORDER BY refers to a multiplier - we will need to replace the
670             # skipped order_by elements with their MIN/MAX equivalents as to maintain
671             # the proper overall order without polluting the group criteria (and
672             # possibly changing the outcome entirely)
673              
674 66         181 my ($leftovers, $sql_maker, @new_order_by, $order_chunks, $aliastypes);
675              
676 66         356 my $group_already_unique = $self->_columns_comprise_identifying_set($colinfos, \@group_by);
677              
678 66         248 for my $o_idx (0 .. $#order_by) {
679              
680             # if the chunk is already a min/max function - there is nothing left to touch
681 166 50       461 next if $order_by[$o_idx][0] =~ /^ (?: min | max ) \s* \( .+ \) $/ix;
682              
683             # only consider real columns (for functions the user got to do an explicit group_by)
684 166         228 my $chunk_ci;
685 166 100 100     248 if (
      66        
686 166         709 @{$order_by[$o_idx]} != 1
687             or
688             # only declare an unknown *plain* identifier as "leftover" if we are called with
689             # aliastypes to examine. If there are none - we are still in _resolve_attrs, and
690             # can just assume the user knows what they want
691             ( ! ( $chunk_ci = $colinfos->{$order_by[$o_idx][0]} ) and $attrs->{_aliastypes} )
692             ) {
693 1         3 push @$leftovers, $order_by[$o_idx][0];
694             }
695              
696 166 100       342 next unless $chunk_ci;
697              
698             # no duplication of group criteria
699 163 100       447 next if $group_index{$chunk_ci->{-fq_colname}};
700              
701             $aliastypes ||= (
702             $attrs->{_aliastypes}
703             or
704             $self->_resolve_aliastypes_from_select_args({
705             from => $attrs->{from},
706             order_by => $attrs->{order_by},
707             })
708 75 100 66     384 ) if $group_already_unique;
      66        
709              
710             # check that we are not ordering by a multiplier (if a check is requested at all)
711 75 100 100     431 if (
      100        
712             $group_already_unique
713             and
714             ! $aliastypes->{multiplying}{$chunk_ci->{-source_alias}}
715             and
716             ! $aliastypes->{premultiplied}{$chunk_ci->{-source_alias}}
717             ) {
718 16         43 push @group_by, $chunk_ci->{-fq_colname};
719 16         58 $group_index{$chunk_ci->{-fq_colname}}++
720             }
721             else {
722             # We need to order by external columns without adding them to the group
723             # (eiehter a non-unique selection, or a multi-external)
724             #
725             # This doesn't really make sense in SQL, however from DBICs point
726             # of view is rather valid (e.g. order the leftmost objects by whatever
727             # criteria and get the offset/rows many). There is a way around
728             # this however in SQL - we simply tae the direction of each piece
729             # of the external order and convert them to MIN(X) for ASC or MAX(X)
730             # for DESC, and group_by the root columns. The end result should be
731             # exactly what we expect
732             #
733              
734             # both populated on the first loop over $o_idx
735 59   66     1031 $sql_maker ||= $self->sql_maker;
736             $order_chunks ||= [
737 145 100       3893 map { ref $_ eq 'ARRAY' ? $_ : [ $_ ] } $sql_maker->_order_by_chunks($attrs->{order_by})
738 59   100     295 ];
739              
740 59         461 my ($chunk, $is_desc) = $sql_maker->_split_order_chunk($order_chunks->[$o_idx][0]);
741              
742             # we reached that far - wrap any part of the order_by that "responded"
743             # to an ordering alias into a MIN/MAX
744             $new_order_by[$o_idx] = \[
745             sprintf( '%s( %s )%s',
746             $self->_minmax_operator_for_datatype($chunk_ci->{data_type}, $is_desc),
747             $chunk,
748             ($is_desc ? ' DESC' : ''),
749             ),
750 59 100       286 @ {$order_chunks->[$o_idx]} [ 1 .. $#{$order_chunks->[$o_idx]} ]
  59         250  
  59         167  
751             ];
752             }
753             }
754              
755             $self->throw_exception ( sprintf
756             'Unable to programatically derive a required group_by from the supplied '
757             . 'order_by criteria. To proceed either add an explicit group_by, or '
758             . 'simplify your order_by to only include plain columns '
759             . '(supplied order_by: %s)',
760 66 100       208 join ', ', map { "'$_'" } @$leftovers,
  1         21  
761             ) if $leftovers;
762              
763             # recreate the untouched order parts
764 65 100       201 if (@new_order_by) {
765 46   100     354 $new_order_by[$_] ||= \ $order_chunks->[$_] for ( 0 .. $#$order_chunks );
766             }
767              
768             return (
769             \@group_by,
770 65 100       1258 (@new_order_by ? \@new_order_by : $attrs->{order_by} ), # same ref as original == unchanged
771             );
772             }
773              
774             sub _minmax_operator_for_datatype {
775             #my ($self, $datatype, $want_max) = @_;
776              
777 57 100   57   372 $_[2] ? 'MAX' : 'MIN';
778             }
779              
780             sub _extract_order_criteria {
781 922     922   17629 my ($self, $order_by, $sql_maker) = @_;
782              
783             my $parser = sub {
784 922     922   2841 my ($sql_maker, $order_by, $orig_quote_chars) = @_;
785              
786 922 100       5011 return scalar $sql_maker->_order_by_chunks ($order_by)
787             unless wantarray;
788              
789 900 50       4954 my ($lq, $rq, $sep) = map { quotemeta($_) } (
  2700         33456  
790             ($orig_quote_chars ? @$orig_quote_chars : $sql_maker->_quote_chars),
791             $sql_maker->name_sep
792             );
793              
794 900         2177 my @chunks;
795 900         5010 for ($sql_maker->_order_by_chunks ($order_by) ) {
796 361 100       13810 my $chunk = ref $_ ? [ @$_ ] : [ $_ ];
797 361         1294 ($chunk->[0]) = $sql_maker->_split_order_chunk($chunk->[0]);
798              
799             # order criteria may have come back pre-quoted (literals and whatnot)
800             # this is fragile, but the best we can currently do
801 361 100       3641 $chunk->[0] =~ s/^ $lq (.+?) $rq $sep $lq (.+?) $rq $/"$1.$2"/xe
  108         552  
802             or $chunk->[0] =~ s/^ $lq (.+) $rq $/$1/x;
803              
804 361         1043 push @chunks, $chunk;
805             }
806              
807 900         63220 return @chunks;
808 922         7445 };
809              
810 922 50       2997 if ($sql_maker) {
811 0         0 return $parser->($sql_maker, $order_by);
812             }
813             else {
814 922         19405 $sql_maker = $self->sql_maker;
815              
816             # pass these in to deal with literals coming from
817             # the user or the deep guts of prefetch
818 922         5272 my $orig_quote_chars = [$sql_maker->_quote_chars];
819              
820 922         2910 local $sql_maker->{quote_char};
821 922         3133 return $parser->($sql_maker, $order_by, $orig_quote_chars);
822             }
823             }
824              
825             sub _order_by_is_stable {
826 30     30   567 my ($self, $ident, $order_by, $where) = @_;
827              
828             my @cols = (
829 50         179 ( map { $_->[0] } $self->_extract_order_criteria($order_by) ),
830 30 100       136 ( $where ? keys %{ extract_equality_conditions( $where ) } : () ),
  27 50       132  
831             ) or return 0;
832              
833 30         169 my $colinfo = fromspec_columns_info($ident, \@cols);
834              
835 30 50       197 return keys %$colinfo
836             ? $self->_columns_comprise_identifying_set( $colinfo, \@cols )
837             : 0
838             ;
839             }
840              
841             sub _columns_comprise_identifying_set {
842 96     96   269 my ($self, $colinfo, $columns) = @_;
843              
844 96         179 my $cols_per_src;
845             $cols_per_src -> {$_->{-source_alias}} -> {$_->{-colname}} = $_
846 96         212 for grep { defined $_ } @{$colinfo}{@$columns};
  316         1058  
  96         299  
847              
848 96         379 for (values %$cols_per_src) {
849 87         296 my $src = (values %$_)[0]->{-result_source};
850 87 100       456 return 1 if $src->_identifying_column_set($_);
851             }
852              
853 19         92 return 0;
854             }
855              
856             # this is almost similar to _order_by_is_stable, except it takes
857             # a single rsrc, and will succeed only if the first portion of the order
858             # by is stable.
859             # returns that portion as a colinfo hashref on success
860             sub _extract_colinfo_of_stable_main_source_order_by_portion {
861 43     43   1209 my ($self, $attrs) = @_;
862              
863 43         273 my $nodes = find_join_path_to_alias($attrs->{from}, $attrs->{alias});
864              
865 43 50       164 return unless defined $nodes;
866              
867             my @ord_cols = map
868 124         334 { $_->[0] }
869 43         242 ( $self->_extract_order_criteria($attrs->{order_by}) )
870             ;
871 43 50       190 return unless @ord_cols;
872              
873 45         185 my $valid_aliases = { map { $_ => 1 } (
874             $attrs->{from}[0]{-alias},
875 43         184 map { values %$_ } @$nodes,
  2         8  
876             ) };
877              
878 43         232 my $colinfos = fromspec_columns_info($attrs->{from});
879              
880 43         123 my ($colinfos_to_return, $seen_main_src_cols);
881              
882 43         134 for my $col (@ord_cols) {
883             # if order criteria is unresolvable - there is nothing we can do
884 111 100       329 my $colinfo = $colinfos->{$col} or last;
885              
886             # if we reached the end of the allowed aliases - also nothing we can do
887 94 100       261 last unless $valid_aliases->{$colinfo->{-source_alias}};
888              
889 86         173 $colinfos_to_return->{$col} = $colinfo;
890              
891             $seen_main_src_cols->{$colinfo->{-colname}} = 1
892 86 100       291 if $colinfo->{-source_alias} eq $attrs->{alias};
893             }
894              
895             # FIXME: the condition may be singling out things on its own, so we
896             # conceivably could come back with "stable-ordered by nothing"
897             # not confident enough in the parser yet, so punt for the time being
898 43 100       322 return unless $seen_main_src_cols;
899              
900             my $main_src_fixed_cols_from_cond = [ $attrs->{where}
901             ? (
902             map
903             {
904             ( $colinfos->{$_} and $colinfos->{$_}{-source_alias} eq $attrs->{alias} )
905             ? $colinfos->{$_}{-colname}
906             : ()
907 26 100 66     181 }
908 35 100       123 keys %{ extract_equality_conditions( $attrs->{where} ) }
  18         97  
909             )
910             : ()
911             ];
912              
913             return $attrs->{result_source}->_identifying_column_set([
914 35 50       279 keys %$seen_main_src_cols,
915             @$main_src_fixed_cols_from_cond,
916             ]) ? $colinfos_to_return : ();
917             }
918              
919             sub _resolve_column_info :DBIC_method_is_indirect_sugar {
920 0     0   0 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
921 0         0 carp_unique("_resolve_column_info() is deprecated, ask on IRC for a better alternative");
922              
923 0         0 fromspec_columns_info( @_[1,2] );
924 233     233   930234 }
  233         706  
  233         1617  
925              
926             sub _find_join_path_to_node :DBIC_method_is_indirect_sugar {
927 0     0   0 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
928 0         0 carp_unique("_find_join_path_to_node() is deprecated, ask on IRC for a better alternative");
929              
930 0         0 find_join_path_to_alias( @_[1,2] );
931 233     233   61360 }
  233         632  
  233         1112  
932              
933             sub _collapse_cond :DBIC_method_is_indirect_sugar {
934 0     0   0 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
935 0         0 carp_unique("_collapse_cond() is deprecated, ask on IRC for a better alternative");
936              
937 0         0 shift;
938 0         0 DBIx::Class::SQLMaker::Util::normalize_sqla_condition(@_);
939 233     233   50690 }
  233         645  
  233         1094  
940              
941             sub _extract_fixed_condition_columns :DBIC_method_is_indirect_sugar {
942 0     0   0 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
943 0         0 carp_unique("_extract_fixed_condition_columns() is deprecated, ask on IRC for a better alternative");
944              
945 0         0 shift;
946 0         0 extract_equality_conditions(@_);
947 233     233   50031 }
  233         643  
  233         1109  
948              
949             sub _resolve_ident_sources :DBIC_method_is_indirect_sugar {
950 0     0   0 DBIx::Class::Exception->throw(
951             '_resolve_ident_sources() has been removed with no replacement, '
952             . 'ask for advice on IRC if this affected you'
953             );
954 233     233   46109 }
  233         610  
  233         1127  
955              
956             sub _inner_join_to_node :DBIC_method_is_indirect_sugar {
957 0     0   0 DBIx::Class::Exception->throw(
958             '_inner_join_to_node() has been removed with no replacement, '
959             . 'ask for advice on IRC if this affected you'
960             );
961 233     233   46694 }
  233         717  
  233         1098  
962              
963             1;