-package DBIx::Class::Storage::DBIHacks;
+package #hide from PAUSE
+ DBIx::Class::Storage::DBIHacks;
#
# This module contains code that should never have seen the light of day,
use Carp::Clan qw/^DBIx::Class/;
#
+# This code will remove non-selecting/non-restricting joins from
+# {from} specs, aiding the RDBMS query optimizer
+#
+sub _prune_unused_joins {
+ my ($self) = shift;
+
+ my ($from, $select, $where, $attrs) = @_;
+
+ if (ref $from ne 'ARRAY' || ref $from->[0] ne 'HASH' || ref $from->[1] ne 'ARRAY') {
+ return $from; # only standard {from} specs are supported
+ }
+
+ my $aliastypes = $self->_resolve_aliastypes_from_select_args(@_);
+
+ # a grouped set will not be affected by amount of rows. Thus any
+ # {multiplying} joins can go
+ delete $aliastypes->{multiplying} if $attrs->{group_by};
+
+
+ my @newfrom = $from->[0]; # FROM head is always present
+
+ my %need_joins = (map { %{$_||{}} } (values %$aliastypes) );
+ for my $j (@{$from}[1..$#$from]) {
+ push @newfrom, $j if (
+ (! $j->[0]{-alias}) # legacy crap
+ ||
+ $need_joins{$j->[0]{-alias}}
+ );
+ }
+
+ return \@newfrom;
+}
+
+#
# This is the code producing joined subqueries like:
# SELECT me.*, other.* FROM ( SELECT me.* FROM ... ) JOIN other ON ...
#
];
}
-
# generate the inner/outer select lists
# for inside we consider only stuff *not* brought in by the prefetch
# on the outside we substitute any function for its alias
push @$inner_select, $sel;
}
- # normalize a copy of $from, so it will be easier to work with further
- # down (i.e. promote the initial hashref to an AoH)
- $from = [ @$from ];
- $from->[0] = [ $from->[0] ];
- my %original_join_info = map { $_->[0]{-alias} => $_->[0] } (@$from);
-
-
- # decide which parts of the join will remain in either part of
- # the outer/inner query
-
- # First we compose a list of which aliases are used in restrictions
- # (i.e. conditions/order/grouping/etc). Since we do not have
- # introspectable SQLA, we fall back to ugly scanning of raw SQL for
- # WHERE, and for pieces of ORDER BY in order to determine which aliases
- # need to appear in the resulting sql.
- # It may not be very efficient, but it's a reasonable stop-gap
- # Also unqualified column names will not be considered, but more often
- # than not this is actually ok
- #
- # In the same loop we enumerate part of the selection aliases, as
- # it requires the same sqla hack for the time being
- my ($restrict_aliases, $select_aliases, $prefetch_aliases);
- {
- # produce stuff unquoted, so it can be scanned
- my $sql_maker = $self->sql_maker;
- local $sql_maker->{quote_char};
- my $sep = $self->_sql_maker_opts->{name_sep} || '.';
- $sep = "\Q$sep\E";
-
- my $non_prefetch_select_sql = $sql_maker->_recurse_fields ($inner_select);
- my $prefetch_select_sql = $sql_maker->_recurse_fields ($outer_attrs->{_prefetch_select});
- my $where_sql = $sql_maker->where ($where);
- my $group_by_sql = $sql_maker->_order_by({
- map { $_ => $inner_attrs->{$_} } qw/group_by having/
- });
- my @non_prefetch_order_by_chunks = (map
- { ref $_ ? $_->[0] : $_ }
- $sql_maker->_order_by_chunks ($inner_attrs->{order_by})
- );
-
-
- for my $alias (keys %original_join_info) {
- my $seen_re = qr/\b $alias $sep/x;
-
- for my $piece ($where_sql, $group_by_sql, @non_prefetch_order_by_chunks ) {
- if ($piece =~ $seen_re) {
- $restrict_aliases->{$alias} = 1;
- }
- }
-
- if ($non_prefetch_select_sql =~ $seen_re) {
- $select_aliases->{$alias} = 1;
- }
-
- if ($prefetch_select_sql =~ $seen_re) {
- $prefetch_aliases->{$alias} = 1;
- }
-
- }
- }
-
- # Add any non-left joins to the restriction list (such joins are indeed restrictions)
- for my $j (values %original_join_info) {
- my $alias = $j->{-alias} or next;
- $restrict_aliases->{$alias} = 1 if (
- (not $j->{-join_type})
- or
- ($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi)
- );
- }
-
- # mark all join parents as mentioned
- # (e.g. join => { cds => 'tracks' } - tracks will need to bring cds too )
- for my $collection ($restrict_aliases, $select_aliases) {
- for my $alias (keys %$collection) {
- $collection->{$_} = 1
- for (@{ $original_join_info{$alias}{-join_path} || [] });
- }
- }
-
# construct the inner $from for the subquery
- my %inner_joins = (map { %{$_ || {}} } ($restrict_aliases, $select_aliases) );
- my @inner_from;
- for my $j (@$from) {
- push @inner_from, $j if $inner_joins{$j->[0]{-alias}};
- }
+ # we need to prune first, because this will determine if we need a group_by below
+ my $inner_from = $self->_prune_unused_joins ($from, $inner_select, $where, $inner_attrs);
- # if a multi-type join was needed in the subquery ("multi" is indicated by
- # presence in {collapse}) - add a group_by to simulate the collapse in the subq
- unless ($inner_attrs->{group_by}) {
- for my $alias (keys %inner_joins) {
-
- # the dot comes from some weirdness in collapse
- # remove after the rewrite
- if ($attrs->{collapse}{".$alias"}) {
- $inner_attrs->{group_by} ||= $inner_select;
- last;
- }
- }
- }
-
- # demote the inner_from head
- $inner_from[0] = $inner_from[0][0];
+ # if a multi-type join was needed in the subquery - add a group_by to simulate the
+ # collapse in the subq
+ $inner_attrs->{group_by} ||= $inner_select
+ if List::Util::first
+ { ! $_->[0]{-is_single} }
+ (@{$inner_from}[1 .. $#$inner_from])
+ ;
# generate the subquery
my $subq = $self->_select_args_to_query (
- \@inner_from,
+ $inner_from,
$inner_select,
$where,
$inner_attrs,
my $subq_joinspec = {
-alias => $attrs->{alias},
- -source_handle => $inner_from[0]{-source_handle},
+ -source_handle => $inner_from->[0]{-source_handle},
$attrs->{alias} => $subq,
};
# - it is part of the restrictions, in which case we need to collapse the outer
# result by tackling yet another group_by to the outside of the query
+ # normalize a copy of $from, so it will be easier to work with further
+ # down (i.e. promote the initial hashref to an AoH)
+ $from = [ @$from ];
+ $from->[0] = [ $from->[0] ];
+
# so first generate the outer_from, up to the substitution point
my @outer_from;
while (my $j = shift @$from) {
}
}
+ # scan the from spec against different attributes, and see which joins are needed
+ # in what role
+ my $outer_aliastypes =
+ $self->_resolve_aliastypes_from_select_args( $from, $outer_select, $where, $outer_attrs );
+
# see what's left - throw away if not selecting/restricting
# also throw in a group_by if restricting to guard against
# cross-join explosions
while (my $j = shift @$from) {
my $alias = $j->[0]{-alias};
- if ($select_aliases->{$alias} || $prefetch_aliases->{$alias}) {
+ if ($outer_aliastypes->{selecting}{$alias}) {
push @outer_from, $j;
}
- elsif ($restrict_aliases->{$alias}) {
+ elsif ($outer_aliastypes->{restricting}{$alias}) {
push @outer_from, $j;
-
- # FIXME - this should be obviated by SQLA2, as I'll be able to
- # have restrict_inner and restrict_outer... or something to that
- # effect... I think...
-
- # FIXME2 - I can't find a clean way to determine if a particular join
- # is a multi - instead I am just treating everything as a potential
- # explosive join (ribasushi)
- #
- # if (my $handle = $j->[0]{-source_handle}) {
- # my $rsrc = $handle->resolve;
- # ... need to bail out of the following if this is not a multi,
- # as it will be much easier on the db ...
-
- $outer_attrs->{group_by} ||= $outer_select;
- # }
+ $outer_attrs->{group_by} ||= $outer_select unless $j->[0]{-is_single};
}
}
return (\@outer_from, $outer_select, $where, $outer_attrs);
}
+#
+# I KNOW THIS SUCKS! GET SQLA2 OUT THE DOOR SO THIS CAN DIE!
+#
+# Due to a lack of SQLA2 we fall back to crude scans of all the
+# select/where/order/group attributes, in order to determine what
+# aliases are neded to fulfill the query. This information is used
+# throughout the code to prune unnecessary JOINs from the queries
+# in an attempt to reduce the execution time.
+# Although the method is pretty horrific, the worst thing that can
+# happen is for it to fail due to some scalar SQL, which in turn will
+# result in a vocal exception.
+sub _resolve_aliastypes_from_select_args {
+ my ( $self, $from, $select, $where, $attrs ) = @_;
+
+ $self->throw_exception ('Unable to analyze custom {from}')
+ if ref $from ne 'ARRAY';
+
+ # what we will return
+ my $aliases_by_type;
+
+ # see what aliases are there to work with
+ my $alias_list;
+ for (@$from) {
+ my $j = $_;
+ $j = $j->[0] if ref $j eq 'ARRAY';
+ my $al = $j->{-alias}
+ or next;
+
+ $alias_list->{$al} = $j;
+ $aliases_by_type->{multiplying}{$al} = 1
+ unless $j->{-is_single};
+ }
+
+ # get a column to source/alias map (including unqualified ones)
+ my $colinfo = $self->_resolve_column_info ($from);
+
+ # set up a botched SQLA
+ my $sql_maker = $self->sql_maker;
+ my $sep = quotemeta ($self->_sql_maker_opts->{name_sep} || '.');
+
+ my ($orig_lquote, $orig_rquote) = map { quotemeta $_ } (do {
+ if (ref $sql_maker->{quote_char} eq 'ARRAY') {
+ @{$sql_maker->{quote_char}}
+ }
+ else {
+ ($sql_maker->{quote_char} || '') x 2;
+ }
+ });
+
+ local $sql_maker->{quote_char} = "\x00"; # so that we can regex away
+
+ # generate sql chunks
+ my $to_scan = {
+ restricting => [
+ $sql_maker->_recurse_where ($where),
+ $sql_maker->_order_by({
+ map { $_ => $attrs->{$_} } (qw/group_by having/)
+ }),
+ ],
+ selecting => [
+ $self->_parse_order_by ($attrs->{order_by}, $sql_maker),
+ $sql_maker->_recurse_fields ($select),
+ ],
+ };
+
+ # throw away empty chunks
+ $_ = [ map { $_ || () } @$_ ] for values %$to_scan;
+
+ # first loop through all fully qualified columns and get the corresponding
+ # alias (should work even if they are in scalarrefs)
+ for my $alias (keys %$alias_list) {
+ my $al_re = qr/
+ \x00 $alias \x00 $sep
+ |
+ \b $alias $sep
+ /x;
+
+ # add matching for possible quoted literal sql
+ $al_re = qr/ $al_re | $orig_lquote $alias $orig_rquote /x
+ if ($orig_lquote && $orig_rquote);
+
+
+ for my $type (keys %$to_scan) {
+ for my $piece (@{$to_scan->{$type}}) {
+ $aliases_by_type->{$type}{$alias} = 1 if ($piece =~ $al_re);
+ }
+ }
+
+ }
+
+ # now loop through unqualified column names, and try to locate them within
+ # the chunks
+ for my $col (keys %$colinfo) {
+ next if $col =~ $sep; # if column is qualified it was caught by the above
+
+ my $col_re = qr/ \x00 $col \x00 /x;
+
+ $col_re = qr/ $col_re | $orig_lquote $col $orig_rquote /x
+ if ($orig_lquote && $orig_rquote);
+
+ for my $type (keys %$to_scan) {
+ for my $piece (@{$to_scan->{$type}}) {
+ $aliases_by_type->{$type}{$colinfo->{$col}{-source_alias}} = 1 if ($piece =~ $col_re);
+ }
+ }
+ }
+
+ # Add any non-left joins to the restriction list (such joins are indeed restrictions)
+ for my $j (values %$alias_list) {
+ my $alias = $j->{-alias} or next;
+ $aliases_by_type->{restricting}{$alias} = 1 if (
+ (not $j->{-join_type})
+ or
+ ($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi)
+ );
+ }
+
+ # mark all join parents as mentioned
+ # (e.g. join => { cds => 'tracks' } - tracks will need to bring cds too )
+ for my $type (keys %$aliases_by_type) {
+ for my $alias (keys %{$aliases_by_type->{$type}}) {
+ $aliases_by_type->{$type}{$_} = 1
+ for (map { keys %$_ } @{ $alias_list->{$alias}{-join_path} || [] });
+ }
+ }
+
+ return $aliases_by_type;
+}
+
sub _resolve_ident_sources {
my ($self, $ident) = @_;
# returns { $column_name => \%column_info, ... }
# also note: this adds -result_source => $rsrc to the column info
#
-# usage:
-# my $col_sources = $self->_resolve_column_info($ident, @column_names);
+# If no columns_names are supplied returns info about *all* columns
+# for all sources
sub _resolve_column_info {
my ($self, $ident, $colnames) = @_;
my ($alias2src, $root_alias) = $self->_resolve_ident_sources($ident);
my $sep = $self->_sql_maker_opts->{name_sep} || '.';
- $sep = "\Q$sep\E";
+ my $qsep = quotemeta $sep;
- my (%return, %seen_cols);
+ my (%return, %seen_cols, @auto_colnames);
# compile a global list of column names, to be able to properly
# disambiguate unqualified column names (if at all possible)
my $rsrc = $alias2src->{$alias};
for my $colname ($rsrc->columns) {
push @{$seen_cols{$colname}}, $alias;
+ push @auto_colnames, "$alias$sep$colname" unless $colnames;
}
}
+ $colnames ||= [
+ @auto_colnames,
+ grep { @{$seen_cols{$_}} == 1 } (keys %seen_cols),
+ ];
+
COLUMN:
foreach my $col (@$colnames) {
- my ($alias, $colname) = $col =~ m/^ (?: ([^$sep]+) $sep)? (.+) $/x;
+ my ($alias, $colname) = $col =~ m/^ (?: ([^$qsep]+) $qsep)? (.+) $/x;
unless ($alias) {
# see if the column was seen exactly once (so we know which rsrc it came from)
# anyway, and deep cloning is just too fucking expensive
# So replace the first hashref in the node arrayref manually
my @new_from = ($from->[0]);
- my $sw_idx = { map { $_ => 1 } @$switch_branch };
+ my $sw_idx = { map { values %$_ => 1 } @$switch_branch };
for my $j (@{$from}[1 .. $#$from]) {
my $jalias = $j->[0]{-alias};
for (my $i = 0; $i < @cond; $i++) {
my $entry = $cond[$i];
my $hash;
- if (ref $entry eq 'HASH') {
+ my $ref = ref $entry;
+ if ($ref eq 'HASH' or $ref eq 'ARRAY') {
$hash = $self->_strip_cond_qualifiers($entry);
}
- else {
+ elsif (! $ref) {
$entry =~ /([^.]+)$/;
$hash->{$1} = $cond[++$i];
}
+ else {
+ $self->throw_exception ("_strip_cond_qualifiers() is unable to handle a condition reftype $ref");
+ }
push @{$cond->{-and}}, $hash;
}
}
return $cond;
}
+sub _parse_order_by {
+ my ($self, $order_by, $sql_maker) = @_;
+
+ my $parser = sub {
+ my ($sql_maker, $order_by) = @_;
+
+ return scalar $sql_maker->_order_by_chunks ($order_by)
+ unless wantarray;
+
+ my @chunks;
+ for my $chunk (map { ref $_ ? @$_ : $_ } ($sql_maker->_order_by_chunks ($order_by) ) ) {
+ $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
+ push @chunks, $chunk;
+ }
+
+ return @chunks;
+ };
+
+ if ($sql_maker) {
+ return $parser->($sql_maker, $order_by);
+ }
+ else {
+ $sql_maker = $self->sql_maker;
+ local $sql_maker->{quote_char};
+ return $parser->($sql_maker, $order_by);
+ }
+}
1;
projects / dbsrgits/DBIx-Class.git / blobdiff