lib/DBIx/Class/SQLMaker/Renderer/OracleJoins.pm

   1 package DBIx::Class::SQLMaker::Renderer::OracleJoins;
   2
   3 sub map_descending (&;@) {
   4   my ($block, $in) = @_;
   5   local $_ = $in;
   6   $_ = $block->($_) if ref($_) eq 'HASH';
   7   if (ref($_) eq 'REF' and ref($$_) eq 'HASH') {
   8     $$_;
   9   } elsif (ref($_) eq 'HASH') {
  10     my $mapped = $_;
  11     local $_;
  12     +{ map +($_ => &map_descending($block, $mapped->{$_})), keys %$mapped };
  13   } elsif (ref($_) eq 'ARRAY') {
  14     [ map &map_descending($block, $_), @$_ ]
  15   } else {
  16     $_
  17   }
  18 }
  19
  20 use Data::Query::ExprHelpers;
  21 use Moo;
  22 use namespace::clean;
  23
  24 extends 'Data::Query::Renderer::SQL::Naive';
  25
  26 around render => sub {
  27   my ($orig, $self) = (shift, shift);
  28   $self->$orig($self->_oracle_joins_unroll(@_));
  29 };
  30
  31 sub _oracle_joins_unroll {
  32   my ($self, $dq) = @_;
  33   map_descending {
  34     return $_ unless is_Join;
  35     return \$self->_oracle_joins_mangle_join($_);
  36   } $dq;
  37 }
  38
  39 sub _oracle_joins_mangle_join {
  40   my ($self, $dq) = @_;
  41   my ($mangled, $where) = $self->_oracle_joins_recurse_join($dq);
  42   Where(
  43     (@$where > 1
  44       ? Operator({ 'SQL.Naive' => 'AND' }, $where)
  45       : $where->[0]),
  46     $mangled
  47   );
  48 }
  49
  50 sub _oracle_joins_recurse_join {
  51   my ($self, $dq) = @_;
  52   die "Can't handle cross join" unless $dq->{on};
  53   my $mangled = { %$dq };
  54   delete @{$mangled}{qw(on outer)};
  55   my @where;
  56   my %idents;
  57   foreach my $side (qw(left right)) {
  58     if (is_Join $dq->{$side}) {
  59       ($mangled->{$side}, my ($side_where, $side_idents))
  60         = $self->_oracle_joins_recurse_join($dq->{$side});
  61       push @where, $side_where;
  62       $idents{$side} = $side_idents;
  63     } else {
  64       if (is_Identifier($dq->{$side})) {
  65         $idents{$side} = { join($;, @{$dq->{$side}{elements}}) => 1 };
  66       } elsif (is_Alias($dq->{$side})) {
  67         $idents{$side} = { $dq->{$side}{to} => 1 };
  68       }
  69       $mangled->{$side} = $self->_oracle_joins_unroll($dq->{$side});
  70     }
  71   }
  72   my %other = (left => 'right', right => 'left');
  73   unshift @where, (
  74     $dq->{outer}
  75       ? map_descending {
  76           return $_
  77             if is_Operator and ($_->{operator}{'SQL.Naive'}||'') eq '(+)';
  78           return $_ unless is_Identifier;
  79           die "Can't unroll single part identifiers in on"
  80             unless @{$_->{elements}} > 1;
  81           my $check = join($;, @{$_->{elements}}[0..($#{$_->{elements}}-1)]);
  82           if ($idents{$other{$dq->{outer}}}{$check}) {
  83             return \Operator({ 'SQL.Naive' => '(+)' }, [ $_ ]);
  84           }
  85           return $_;
  86         } $dq->{on}
  87       : $dq->{on}
  88   );
  89   return ($mangled, \@where, { map %{$_||{}}, @idents{qw(left right)} });
  90 }
  91
  92 around _default_simple_ops => sub {
  93   my ($orig, $self) = (shift, shift);
  94   +{
  95     %{$self->$orig(@_)},
  96     '(+)' => 'unop_reverse',
  97   };
  98 };
  99
 100 1;