beginnings of oracle joins support

diff --git a/lib/DBIx/Class/SQLMaker/OracleJoins.pm b/lib/DBIx/Class/SQLMaker/OracleJoins.pm
index b95c56e..e645382 100644 (file)
--- a/lib/DBIx/Class/SQLMaker/OracleJoins.pm
+++ b/lib/DBIx/Class/SQLMaker/OracleJoins.pm
@@ -2,94 +2,12 @@ package DBIx::Class::SQLMaker::OracleJoins;
 
 use warnings;
 use strict;
+use Module::Runtime ();
 
 use base qw( DBIx::Class::SQLMaker::Oracle );
 
-sub select {
-  my ($self, $table, $fields, $where, $rs_attrs, @rest) = @_;
-
-  # pull out all join conds as regular WHEREs from all extra tables
-  if (ref($table) eq 'ARRAY') {
-    $where = $self->_oracle_joins($where, @{ $table }[ 1 .. $#$table ]);
-  }
-
-  return $self->next::method($table, $fields, $where, $rs_attrs, @rest);
-}
-
-sub _recurse_from {
-  my ($self, $from, @join) = @_;
-
-  my @sqlf = $self->_from_chunk_to_sql($from);
-
-  for (@join) {
-    my ($to, $on) = @$_;
-
-    if (ref $to eq 'ARRAY') {
-      push (@sqlf, $self->_recurse_from(@{ $to }));
-    }
-    else {
-      push (@sqlf, $self->_from_chunk_to_sql($to));
-    }
-  }
-
-  return join q{, }, @sqlf;
-}
-
-sub _oracle_joins {
-  my ($self, $where, @join) = @_;
-  my $join_where = $self->_recurse_oracle_joins(@join);
-
-  if (keys %$join_where) {
-    if (!defined($where)) {
-      $where = $join_where;
-    } else {
-      if (ref($where) eq 'ARRAY') {
-        $where = { -or => $where };
-      }
-      $where = { -and => [ $join_where, $where ] };
-    }
-  }
-  return $where;
-}
-
-sub _recurse_oracle_joins {
-  my $self = shift;
-
-  my @where;
-  for my $j (@_) {
-    my ($to, $on) = @{ $j };
-
-    push @where, $self->_recurse_oracle_joins(@{ $to })
-      if (ref $to eq 'ARRAY');
-
-    my $join_opts  = ref $to eq 'ARRAY' ? $to->[0] : $to;
-    my $left_join  = q{};
-    my $right_join = q{};
-
-    if (ref $join_opts eq 'HASH' and my $jt = $join_opts->{-join_type}) {
-      #TODO: Support full outer joins -- this would happen much earlier in
-      #the sequence since oracle 8's full outer join syntax is best
-      #described as INSANE.
-      $self->throw_exception("Can't handle full outer joins in Oracle 8 yet!\n")
-        if $jt =~ /full/i;
-
-      $left_join  = q{(+)} if $jt =~ /left/i
-        && $jt !~ /inner/i;
-
-      $right_join = q{(+)} if $jt =~ /right/i
-        && $jt !~ /inner/i;
-    }
-
-    # sadly SQLA treats where($scalar) as literal, so we need to jump some hoops
-    push @where, map { \sprintf ('%s%s = %s%s',
-      ref $_ ? $self->_recurse_where($_) : $self->_quote($_),
-      $left_join,
-      ref $on->{$_} ? $self->_recurse_where($on->{$_}) : $self->_quote($on->{$_}),
-      $right_join,
-    )} keys %$on;
-  }
-
-  return { -and => \@where };
+sub _build_base_renderer_class {
+  Module::Runtime::use_module('DBIx::Class::SQLMaker::Renderer::OracleJoins');
 }
 
 1;

diff --git a/lib/DBIx/Class/SQLMaker/Renderer/Access.pm b/lib/DBIx/Class/SQLMaker/Renderer/Access.pm
new file mode 100644 (file)
index 0000000..128896d
--- /dev/null
+++ b/lib/DBIx/Class/SQLMaker/Renderer/Access.pm
@@ -0,0 +1,14 @@
+package DBIx::Class::SQLMaker::Renderer::Access;
+
+use Moo;
+
+extends 'Data::Query::Renderer::SQL::Naive';
+
+around _render_join => sub {
+  my ($orig, $self) = (shift, shift);
+  my ($dq) = @_;
+  local $dq->{outer} = 'INNER' if $dq->{on} and !$dq->{outer};
+  [ '(', @{$self->$orig(@_)}, ')' ];
+};
+
+1;

diff --git a/lib/DBIx/Class/SQLMaker/Renderer/OracleJoins.pm b/lib/DBIx/Class/SQLMaker/Renderer/OracleJoins.pm
new file mode 100644 (file)
index 0000000..d5045c7
--- /dev/null
+++ b/lib/DBIx/Class/SQLMaker/Renderer/OracleJoins.pm
@@ -0,0 +1,96 @@
+package DBIx::Class::SQLMaker::Renderer::OracleJoins;
+
+sub map_descending (&;@) {
+  my ($block, @in) = @_;
+  local $_;
+  map {
+    if (ref($_) eq 'REF' and ref($$_) eq 'HASH') {
+      $$_;
+    } elsif (ref($_) eq 'HASH') {
+      my $mapped = $block->($_);
+      local $_;
+      +{ map +($_ => &map_descending($block, $mapped->{$_})), keys %$mapped };
+    } elsif (ref($_) eq 'ARRAY') {
+      [ &map_descending($block, @$_) ]
+    } else {
+      $_
+    }
+  } @in;
+}
+
+use Data::Query::ExprHelpers;
+use Moo;
+
+extends 'Data::Query::Renderer::SQL::Naive';
+
+around render => sub {
+  my ($orig, $self) = (shift, shift);
+  $self->$orig($self->_oracle_joins_unroll(@_));
+};
+
+sub _oracle_joins_unroll {
+  my ($self, $dq) = @_;
+  ::Dwarn map_descending {
+    return $_ unless is_Join;
+    return $self->_oracle_joins_mangle_join($_);
+  } $dq;
+}
+
+sub _oracle_joins_mangle_join {
+  my ($self, $dq) = @_;
+  my ($mangled, $where) = $self->_oracle_joins_recurse_join($dq);
+  Where(
+    Operator({ 'SQL.Naive' => 'and' }, $where),
+    $mangled
+  );
+}
+
+sub _oracle_joins_recurse_join {
+  my ($self, $dq) = @_;
+  die "Can't handle cross join" unless $dq->{on};
+  my $mangled = { %$dq };
+  my @where;
+  my %idents;
+  foreach my $side (qw(left right)) {
+    if (is_Join $dq->{$side}) {
+      ($mangled->{$side}, my ($side_where, $side_idents))
+        = $self->_oracle_joins_recurse_join($dq->{$side});
+      push @where, $side_where;
+      $idents{$side} = $side_idents;
+    } else {
+      if (is_Identifier($dq->{$side})) {
+        $idents{$side} = { join($;, @{$dq->{$side}{elements}}) => 1 };
+      } elsif (is_Alias($dq->{$side})) {
+        $idents{$side} = { $dq->{$side}{to} => 1 };
+      }
+      $mangled->{$side} = $self->_oracle_joins_unroll($dq->{side});
+    }
+  }
+  unshift @where, (
+    $dq->{outer}
+      ? map_descending {
+          return $_
+            if is_Operator and ($_->{operator}{'SQL.Naive'}||'') eq '(+)';
+          return $_ unless is_Identifier;
+          die "Can't unroll single part identifiers in on"
+            unless @{$_->{elements}} > 1;
+          my $check = join($;, @{$_->{elements}}[0..($#{$_->{elements}}-1)]);
+          if ($idents{$dq->{outer}}{$check}) {
+            return \Operator({ 'SQL.Naive' => '(+)' }, [ $_ ]);
+          }
+          return $_;
+        } $dq->{on}
+      : $dq->{on}
+  );
+  return ($mangled, \@where, { map %{$_||{}}, @idents{qw(left right)} });
+}
+
+around _default_simple_ops => sub {
+  my ($orig, $self) = (shift, shift);
+  +{
+    %{$self->$orig(@_)},
+    '(+)' => 'unop_reverse',
+  };
+};
+
+1;