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