split connect_info parser out into private _normalize_connect_info
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBIHacks.pm
1 package   #hide from PAUSE
2   DBIx::Class::Storage::DBIHacks;
3
4 #
5 # This module contains code that should never have seen the light of day,
6 # does not belong in the Storage, or is otherwise unfit for public
7 # display. The arrival of SQLA2 should immediately oboslete 90% of this
8 #
9
10 use strict;
11 use warnings;
12
13 use base 'DBIx::Class::Storage';
14 use mro 'c3';
15
16 use Carp::Clan qw/^DBIx::Class/;
17
18 #
19 # This is the code producing joined subqueries like:
20 # SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ... 
21 #
22 sub _adjust_select_args_for_complex_prefetch {
23   my ($self, $from, $select, $where, $attrs) = @_;
24
25   $self->throw_exception ('Nothing to prefetch... how did we get here?!')
26     if not @{$attrs->{_prefetch_select}};
27
28   $self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute')
29     if (ref $from ne 'ARRAY' || ref $from->[0] ne 'HASH' || ref $from->[1] ne 'ARRAY');
30
31
32   # generate inner/outer attribute lists, remove stuff that doesn't apply
33   my $outer_attrs = { %$attrs };
34   delete $outer_attrs->{$_} for qw/where bind rows offset group_by having/;
35
36   my $inner_attrs = { %$attrs };
37   delete $inner_attrs->{$_} for qw/for collapse _prefetch_select _collapse_order_by select as/;
38
39
40   # bring over all non-collapse-induced order_by into the inner query (if any)
41   # the outer one will have to keep them all
42   delete $inner_attrs->{order_by};
43   if (my $ord_cnt = @{$outer_attrs->{order_by}} - @{$outer_attrs->{_collapse_order_by}} ) {
44     $inner_attrs->{order_by} = [
45       @{$outer_attrs->{order_by}}[ 0 .. $ord_cnt - 1]
46     ];
47   }
48
49
50   # generate the inner/outer select lists
51   # for inside we consider only stuff *not* brought in by the prefetch
52   # on the outside we substitute any function for its alias
53   my $outer_select = [ @$select ];
54   my $inner_select = [];
55   for my $i (0 .. ( @$outer_select - @{$outer_attrs->{_prefetch_select}} - 1) ) {
56     my $sel = $outer_select->[$i];
57
58     if (ref $sel eq 'HASH' ) {
59       $sel->{-as} ||= $attrs->{as}[$i];
60       $outer_select->[$i] = join ('.', $attrs->{alias}, ($sel->{-as} || "inner_column_$i") );
61     }
62
63     push @$inner_select, $sel;
64   }
65
66   # normalize a copy of $from, so it will be easier to work with further
67   # down (i.e. promote the initial hashref to an AoH)
68   $from = [ @$from ];
69   $from->[0] = [ $from->[0] ];
70   my %original_join_info = map { $_->[0]{-alias} => $_->[0] } (@$from);
71
72
73   # decide which parts of the join will remain in either part of
74   # the outer/inner query
75
76   # First we compose a list of which aliases are used in restrictions
77   # (i.e. conditions/order/grouping/etc). Since we do not have
78   # introspectable SQLA, we fall back to ugly scanning of raw SQL for
79   # WHERE, and for pieces of ORDER BY in order to determine which aliases
80   # need to appear in the resulting sql.
81   # It may not be very efficient, but it's a reasonable stop-gap
82   # Also unqualified column names will not be considered, but more often
83   # than not this is actually ok
84   #
85   # In the same loop we enumerate part of the selection aliases, as
86   # it requires the same sqla hack for the time being
87   my ($restrict_aliases, $select_aliases, $prefetch_aliases);
88   {
89     # produce stuff unquoted, so it can be scanned
90     my $sql_maker = $self->sql_maker;
91     local $sql_maker->{quote_char};
92     my $sep = $self->_sql_maker_opts->{name_sep} || '.';
93     $sep = "\Q$sep\E";
94
95     my $non_prefetch_select_sql = $sql_maker->_recurse_fields ($inner_select);
96     my $prefetch_select_sql = $sql_maker->_recurse_fields ($outer_attrs->{_prefetch_select});
97     my $where_sql = $sql_maker->where ($where);
98     my $group_by_sql = $sql_maker->_order_by({
99       map { $_ => $inner_attrs->{$_} } qw/group_by having/
100     });
101     my @non_prefetch_order_by_chunks = (map
102       { ref $_ ? $_->[0] : $_ }
103       $sql_maker->_order_by_chunks ($inner_attrs->{order_by})
104     );
105
106
107     for my $alias (keys %original_join_info) {
108       my $seen_re = qr/\b $alias $sep/x;
109
110       for my $piece ($where_sql, $group_by_sql, @non_prefetch_order_by_chunks ) {
111         if ($piece =~ $seen_re) {
112           $restrict_aliases->{$alias} = 1;
113         }
114       }
115
116       if ($non_prefetch_select_sql =~ $seen_re) {
117           $select_aliases->{$alias} = 1;
118       }
119
120       if ($prefetch_select_sql =~ $seen_re) {
121           $prefetch_aliases->{$alias} = 1;
122       }
123
124     }
125   }
126
127   # Add any non-left joins to the restriction list (such joins are indeed restrictions)
128   for my $j (values %original_join_info) {
129     my $alias = $j->{-alias} or next;
130     $restrict_aliases->{$alias} = 1 if (
131       (not $j->{-join_type})
132         or
133       ($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi)
134     );
135   }
136
137   # mark all join parents as mentioned
138   # (e.g.  join => { cds => 'tracks' } - tracks will need to bring cds too )
139   for my $collection ($restrict_aliases, $select_aliases) {
140     for my $alias (keys %$collection) {
141       $collection->{$_} = 1
142         for (@{ $original_join_info{$alias}{-join_path} || [] });
143     }
144   }
145
146   # construct the inner $from for the subquery
147   my %inner_joins = (map { %{$_ || {}} } ($restrict_aliases, $select_aliases) );
148   my @inner_from;
149   for my $j (@$from) {
150     push @inner_from, $j if $inner_joins{$j->[0]{-alias}};
151   }
152
153   # if a multi-type join was needed in the subquery ("multi" is indicated by
154   # presence in {collapse}) - add a group_by to simulate the collapse in the subq
155   unless ($inner_attrs->{group_by}) {
156     for my $alias (keys %inner_joins) {
157
158       # the dot comes from some weirdness in collapse
159       # remove after the rewrite
160       if ($attrs->{collapse}{".$alias"}) {
161         $inner_attrs->{group_by} ||= $inner_select;
162         last;
163       }
164     }
165   }
166
167   # demote the inner_from head
168   $inner_from[0] = $inner_from[0][0];
169
170   # generate the subquery
171   my $subq = $self->_select_args_to_query (
172     \@inner_from,
173     $inner_select,
174     $where,
175     $inner_attrs,
176   );
177
178   my $subq_joinspec = {
179     -alias => $attrs->{alias},
180     -source_handle => $inner_from[0]{-source_handle},
181     $attrs->{alias} => $subq,
182   };
183
184   # Generate the outer from - this is relatively easy (really just replace
185   # the join slot with the subquery), with a major caveat - we can not
186   # join anything that is non-selecting (not part of the prefetch), but at
187   # the same time is a multi-type relationship, as it will explode the result.
188   #
189   # There are two possibilities here
190   # - either the join is non-restricting, in which case we simply throw it away
191   # - it is part of the restrictions, in which case we need to collapse the outer
192   #   result by tackling yet another group_by to the outside of the query
193
194   # so first generate the outer_from, up to the substitution point
195   my @outer_from;
196   while (my $j = shift @$from) {
197     if ($j->[0]{-alias} eq $attrs->{alias}) { # time to swap
198       push @outer_from, [
199         $subq_joinspec,
200         @{$j}[1 .. $#$j],
201       ];
202       last; # we'll take care of what's left in $from below
203     }
204     else {
205       push @outer_from, $j;
206     }
207   }
208
209   # see what's left - throw away if not selecting/restricting
210   # also throw in a group_by if restricting to guard against
211   # cross-join explosions
212   #
213   while (my $j = shift @$from) {
214     my $alias = $j->[0]{-alias};
215
216     if ($select_aliases->{$alias} || $prefetch_aliases->{$alias}) {
217       push @outer_from, $j;
218     }
219     elsif ($restrict_aliases->{$alias}) {
220       push @outer_from, $j;
221
222       # FIXME - this should be obviated by SQLA2, as I'll be able to 
223       # have restrict_inner and restrict_outer... or something to that
224       # effect... I think...
225
226       # FIXME2 - I can't find a clean way to determine if a particular join
227       # is a multi - instead I am just treating everything as a potential
228       # explosive join (ribasushi)
229       #
230       # if (my $handle = $j->[0]{-source_handle}) {
231       #   my $rsrc = $handle->resolve;
232       #   ... need to bail out of the following if this is not a multi,
233       #       as it will be much easier on the db ...
234
235           $outer_attrs->{group_by} ||= $outer_select;
236       # }
237     }
238   }
239
240   # demote the outer_from head
241   $outer_from[0] = $outer_from[0][0];
242
243   # This is totally horrific - the $where ends up in both the inner and outer query
244   # Unfortunately not much can be done until SQLA2 introspection arrives, and even
245   # then if where conditions apply to the *right* side of the prefetch, you may have
246   # to both filter the inner select (e.g. to apply a limit) and then have to re-filter
247   # the outer select to exclude joins you didin't want in the first place
248   #
249   # OTOH it can be seen as a plus: <ash> (notes that this query would make a DBA cry ;)
250   return (\@outer_from, $outer_select, $where, $outer_attrs);
251 }
252
253 sub _resolve_ident_sources {
254   my ($self, $ident) = @_;
255
256   my $alias2source = {};
257   my $rs_alias;
258
259   # the reason this is so contrived is that $ident may be a {from}
260   # structure, specifying multiple tables to join
261   if ( Scalar::Util::blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
262     # this is compat mode for insert/update/delete which do not deal with aliases
263     $alias2source->{me} = $ident;
264     $rs_alias = 'me';
265   }
266   elsif (ref $ident eq 'ARRAY') {
267
268     for (@$ident) {
269       my $tabinfo;
270       if (ref $_ eq 'HASH') {
271         $tabinfo = $_;
272         $rs_alias = $tabinfo->{-alias};
273       }
274       if (ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH') {
275         $tabinfo = $_->[0];
276       }
277
278       $alias2source->{$tabinfo->{-alias}} = $tabinfo->{-source_handle}->resolve
279         if ($tabinfo->{-source_handle});
280     }
281   }
282
283   return ($alias2source, $rs_alias);
284 }
285
286 # Takes $ident, \@column_names
287 #
288 # returns { $column_name => \%column_info, ... }
289 # also note: this adds -result_source => $rsrc to the column info
290 #
291 # If no columns_names are supplied returns info about *all* columns
292 # for all sources
293 sub _resolve_column_info {
294   my ($self, $ident, $colnames) = @_;
295   my ($alias2src, $root_alias) = $self->_resolve_ident_sources($ident);
296
297   my $sep = $self->_sql_maker_opts->{name_sep} || '.';
298   my $qsep = quotemeta $sep;
299
300   my (%return, %seen_cols, @auto_colnames);
301
302   # compile a global list of column names, to be able to properly
303   # disambiguate unqualified column names (if at all possible)
304   for my $alias (keys %$alias2src) {
305     my $rsrc = $alias2src->{$alias};
306     for my $colname ($rsrc->columns) {
307       push @{$seen_cols{$colname}}, $alias;
308       push @auto_colnames, "$alias$sep$colname" unless $colnames;
309     }
310   }
311
312   $colnames ||= [
313     @auto_colnames,
314     grep { @{$seen_cols{$_}} == 1 } (keys %seen_cols),
315   ];
316
317   COLUMN:
318   foreach my $col (@$colnames) {
319     my ($alias, $colname) = $col =~ m/^ (?: ([^$qsep]+) $qsep)? (.+) $/x;
320
321     unless ($alias) {
322       # see if the column was seen exactly once (so we know which rsrc it came from)
323       if ($seen_cols{$colname} and @{$seen_cols{$colname}} == 1) {
324         $alias = $seen_cols{$colname}[0];
325       }
326       else {
327         next COLUMN;
328       }
329     }
330
331     my $rsrc = $alias2src->{$alias};
332     $return{$col} = $rsrc && {
333       %{$rsrc->column_info($colname)},
334       -result_source => $rsrc,
335       -source_alias => $alias,
336     };
337   }
338
339   return \%return;
340 }
341
342 # The DBIC relationship chaining implementation is pretty simple - every
343 # new related_relationship is pushed onto the {from} stack, and the {select}
344 # window simply slides further in. This means that when we count somewhere
345 # in the middle, we got to make sure that everything in the join chain is an
346 # actual inner join, otherwise the count will come back with unpredictable
347 # results (a resultset may be generated with _some_ rows regardless of if
348 # the relation which the $rs currently selects has rows or not). E.g.
349 # $artist_rs->cds->count - normally generates:
350 # SELECT COUNT( * ) FROM artist me LEFT JOIN cd cds ON cds.artist = me.artistid
351 # which actually returns the number of artists * (number of cds || 1)
352 #
353 # So what we do here is crawl {from}, determine if the current alias is at
354 # the top of the stack, and if not - make sure the chain is inner-joined down
355 # to the root.
356 #
357 sub _straight_join_to_node {
358   my ($self, $from, $alias) = @_;
359
360   # subqueries and other oddness are naturally not supported
361   return $from if (
362     ref $from ne 'ARRAY'
363       ||
364     @$from <= 1
365       ||
366     ref $from->[0] ne 'HASH'
367       ||
368     ! $from->[0]{-alias}
369       ||
370     $from->[0]{-alias} eq $alias  # this last bit means $alias is the head of $from - nothing to do
371   );
372
373   # find the current $alias in the $from structure
374   my $switch_branch;
375   JOINSCAN:
376   for my $j (@{$from}[1 .. $#$from]) {
377     if ($j->[0]{-alias} eq $alias) {
378       $switch_branch = $j->[0]{-join_path};
379       last JOINSCAN;
380     }
381   }
382
383   # something else went quite wrong
384   return $from unless $switch_branch;
385
386   # So it looks like we will have to switch some stuff around.
387   # local() is useless here as we will be leaving the scope
388   # anyway, and deep cloning is just too fucking expensive
389   # So replace the first hashref in the node arrayref manually 
390   my @new_from = ($from->[0]);
391   my $sw_idx = { map { $_ => 1 } @$switch_branch };
392
393   for my $j (@{$from}[1 .. $#$from]) {
394     my $jalias = $j->[0]{-alias};
395
396     if ($sw_idx->{$jalias}) {
397       my %attrs = %{$j->[0]};
398       delete $attrs{-join_type};
399       push @new_from, [
400         \%attrs,
401         @{$j}[ 1 .. $#$j ],
402       ];
403     }
404     else {
405       push @new_from, $j;
406     }
407   }
408
409   return \@new_from;
410 }
411
412 # Most databases do not allow aliasing of tables in UPDATE/DELETE. Thus
413 # a condition containing 'me' or other table prefixes will not work
414 # at all. What this code tries to do (badly) is introspect the condition
415 # and remove all column qualifiers. If it bails out early (returns undef)
416 # the calling code should try another approach (e.g. a subquery)
417 sub _strip_cond_qualifiers {
418   my ($self, $where) = @_;
419
420   my $cond = {};
421
422   # No-op. No condition, we're updating/deleting everything
423   return $cond unless $where;
424
425   if (ref $where eq 'ARRAY') {
426     $cond = [
427       map {
428         my %hash;
429         foreach my $key (keys %{$_}) {
430           $key =~ /([^.]+)$/;
431           $hash{$1} = $_->{$key};
432         }
433         \%hash;
434       } @$where
435     ];
436   }
437   elsif (ref $where eq 'HASH') {
438     if ( (keys %$where) == 1 && ( (keys %{$where})[0] eq '-and' )) {
439       $cond->{-and} = [];
440       my @cond = @{$where->{-and}};
441        for (my $i = 0; $i < @cond; $i++) {
442         my $entry = $cond[$i];
443         my $hash;
444         if (ref $entry eq 'HASH') {
445           $hash = $self->_strip_cond_qualifiers($entry);
446         }
447         else {
448           $entry =~ /([^.]+)$/;
449           $hash->{$1} = $cond[++$i];
450         }
451         push @{$cond->{-and}}, $hash;
452       }
453     }
454     else {
455       foreach my $key (keys %$where) {
456         $key =~ /([^.]+)$/;
457         $cond->{$1} = $where->{$key};
458       }
459     }
460   }
461   else {
462     return undef;
463   }
464
465   return $cond;
466 }
467
468
469 1;