package DBIx::Class::Storage::DBIHacks;
use strict;
use warnings;
use base 'DBIx::Class::Storage';
use mro 'c3';
use Carp::Clan qw/^DBIx::Class/;
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; }
my $aliastypes = $self->_resolve_aliastypes_from_select_args(@_);
delete $aliastypes->{multiplying} if $attrs->{group_by};
my @newfrom = $from->[0];
my %need_joins = (map { %{$_||{}} } (values %$aliastypes) );
for my $j (@{$from}[1..$ push @newfrom, $j if (
(! $j->[0]{-alias}) ||
$need_joins{$j->[0]{-alias}}
);
}
return \@newfrom;
}
sub _adjust_select_args_for_complex_prefetch {
my ($self, $from, $select, $where, $attrs) = @_;
$self->throw_exception ('Nothing to prefetch... how did we get here?!')
if not @{$attrs->{_prefetch_select}};
$self->throw_exception ('Complex prefetches are not supported on resultsets with a custom from attribute')
if (ref $from ne 'ARRAY' || ref $from->[0] ne 'HASH' || ref $from->[1] ne 'ARRAY');
my $outer_attrs = { %$attrs };
delete $outer_attrs->{$_} for qw/where bind rows offset group_by having/;
my $inner_attrs = { %$attrs };
delete $inner_attrs->{$_} for qw/for collapse _prefetch_select _collapse_order_by select as/;
delete $inner_attrs->{order_by};
if (my $ord_cnt = @{$outer_attrs->{order_by}} - @{$outer_attrs->{_collapse_order_by}} ) {
$inner_attrs->{order_by} = [
@{$outer_attrs->{order_by}}[ 0 .. $ord_cnt - 1]
];
}
my $outer_select = [ @$select ];
my $inner_select = [];
for my $i (0 .. ( @$outer_select - @{$outer_attrs->{_prefetch_select}} - 1) ) {
my $sel = $outer_select->[$i];
if (ref $sel eq 'HASH' ) {
$sel->{-as} ||= $attrs->{as}[$i];
$outer_select->[$i] = join ('.', $attrs->{alias}, ($sel->{-as} || "inner_column_$i") );
}
push @$inner_select, $sel;
}
my $inner_from = $self->_prune_unused_joins ($from, $inner_select, $where, $inner_attrs);
$inner_attrs->{group_by} ||= $inner_select
if List::Util::first
{ ! $_->[0]{-is_single} }
(@{$inner_from}[1 .. $ ;
my $subq = $self->_select_args_to_query (
$inner_from,
$inner_select,
$where,
$inner_attrs,
);
my $subq_joinspec = {
-alias => $attrs->{alias},
-source_handle => $inner_from->[0]{-source_handle},
$attrs->{alias} => $subq,
};
$from = [ @$from ];
$from->[0] = [ $from->[0] ];
my @outer_from;
while (my $j = shift @$from) {
if ($j->[0]{-alias} eq $attrs->{alias}) { push @outer_from, [
$subq_joinspec,
@{$j}[1 .. $ ];
last; }
else {
push @outer_from, $j;
}
}
my $outer_aliastypes =
$self->_resolve_aliastypes_from_select_args( $from, $outer_select, $where, $outer_attrs );
while (my $j = shift @$from) {
my $alias = $j->[0]{-alias};
if ($outer_aliastypes->{select}{$alias}) {
push @outer_from, $j;
}
elsif ($outer_aliastypes->{restrict}{$alias}) {
push @outer_from, $j;
$outer_attrs->{group_by} ||= $outer_select unless $j->[0]{-is_single};
}
}
$outer_from[0] = $outer_from[0][0];
return (\@outer_from, $outer_select, $where, $outer_attrs);
}
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';
my $aliases_by_type;
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};
}
my $sql_maker = $self->sql_maker;
my $sep = quotemeta ($self->_sql_maker_opts->{name_sep} || '.');
local $sql_maker->{quote_char};
my $select_sql = $sql_maker->_recurse_fields ($select);
my $where_sql = $sql_maker->where ($where);
my $group_by_sql = $sql_maker->_order_by({
map { $_ => $attrs->{$_} } qw/group_by having/
});
my @order_by_chunks = ($self->_parse_order_by ($attrs->{order_by}) );
for my $alias (keys %$alias_list) {
my $al_re = qr/\b $alias $sep/x;
for my $piece ($where_sql, $group_by_sql) {
$aliases_by_type->{restrict}{$alias} = 1 if ($piece =~ $al_re);
}
for my $piece ($select_sql, @order_by_chunks ) {
$aliases_by_type->{select}{$alias} = 1 if ($piece =~ $al_re);
}
}
for my $j (values %$alias_list) {
my $alias = $j->{-alias} or next;
$aliases_by_type->{restrict}{$alias} = 1 if (
(not $j->{-join_type})
or
($j->{-join_type} !~ /^left (?: \s+ outer)? $/xi)
);
}
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) = @_;
my $alias2source = {};
my $rs_alias;
if ( Scalar::Util::blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
$alias2source->{me} = $ident;
$rs_alias = 'me';
}
elsif (ref $ident eq 'ARRAY') {
for (@$ident) {
my $tabinfo;
if (ref $_ eq 'HASH') {
$tabinfo = $_;
$rs_alias = $tabinfo->{-alias};
}
if (ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH') {
$tabinfo = $_->[0];
}
$alias2source->{$tabinfo->{-alias}} = $tabinfo->{-source_handle}->resolve
if ($tabinfo->{-source_handle});
}
}
return ($alias2source, $rs_alias);
}
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} || '.';
my $qsep = quotemeta $sep;
my (%return, %seen_cols, @auto_colnames);
for my $alias (keys %$alias2src) {
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/^ (?: ([^$qsep]+) $qsep)? (.+) $/x;
unless ($alias) {
if ($seen_cols{$colname} and @{$seen_cols{$colname}} == 1) {
$alias = $seen_cols{$colname}[0];
}
else {
next COLUMN;
}
}
my $rsrc = $alias2src->{$alias};
$return{$col} = $rsrc && {
%{$rsrc->column_info($colname)},
-result_source => $rsrc,
-source_alias => $alias,
};
}
return \%return;
}
sub _straight_join_to_node {
my ($self, $from, $alias) = @_;
return $from if (
ref $from ne 'ARRAY'
||
@$from <= 1
||
ref $from->[0] ne 'HASH'
||
! $from->[0]{-alias}
||
$from->[0]{-alias} eq $alias );
my $switch_branch;
JOINSCAN:
for my $j (@{$from}[1 .. $ if ($j->[0]{-alias} eq $alias) {
$switch_branch = $j->[0]{-join_path};
last JOINSCAN;
}
}
return $from unless $switch_branch;
my @new_from = ($from->[0]);
my $sw_idx = { map { values %$_ => 1 } @$switch_branch };
for my $j (@{$from}[1 .. $ my $jalias = $j->[0]{-alias};
if ($sw_idx->{$jalias}) {
my %attrs = %{$j->[0]};
delete $attrs{-join_type};
push @new_from, [
\%attrs,
@{$j}[ 1 .. $ ];
}
else {
push @new_from, $j;
}
}
return \@new_from;
}
sub _strip_cond_qualifiers {
my ($self, $where) = @_;
my $cond = {};
return $cond unless $where;
if (ref $where eq 'ARRAY') {
$cond = [
map {
my %hash;
foreach my $key (keys %{$_}) {
$key =~ /([^.]+)$/;
$hash{$1} = $_->{$key};
}
\%hash;
} @$where
];
}
elsif (ref $where eq 'HASH') {
if ( (keys %$where) == 1 && ( (keys %{$where})[0] eq '-and' )) {
$cond->{-and} = [];
my @cond = @{$where->{-and}};
for (my $i = 0; $i < @cond; $i++) {
my $entry = $cond[$i];
my $hash;
my $ref = ref $entry;
if ($ref eq 'HASH' or $ref eq 'ARRAY') {
$hash = $self->_strip_cond_qualifiers($entry);
}
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;
}
}
else {
foreach my $key (keys %$where) {
$key =~ /([^.]+)$/;
$cond->{$1} = $where->{$key};
}
}
}
else {
return undef;
}
return $cond;
}
sub _parse_order_by {
my ($self, $order_by) = @_;
return scalar $self->sql_maker->_order_by_chunks ($order_by)
unless wantarray;
my $sql_maker = $self->sql_maker;
local $sql_maker->{quote_char}; 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;
}
1;