From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sun, 27 May 2012 18:54:32 +0000 (+0000)
Subject: first whack at GenericSubQ, half works
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=410dc8ab18813d2d0aacd2e0ad0b7e6ae7ca8e0e;p=dbsrgits%2FData-Query.git

first whack at GenericSubQ, half works
---

diff --git a/lib/Data/Query/Renderer/SQL/Naive.pm b/lib/Data/Query/Renderer/SQL/Naive.pm
index 42ee8b4..3fa8811 100644
--- a/lib/Data/Query/Renderer/SQL/Naive.pm
+++ b/lib/Data/Query/Renderer/SQL/Naive.pm
@@ -141,15 +141,24 @@ sub _render_operator {
   die "Unsure how to handle ${op_name}";
 }
 
+sub _maybe_parenthesise {
+  my ($self, $dq) = @_;
+  my %parenthesise = map +($_ => 1), DQ_SELECT, DQ_SLICE;
+  return
+    ($parenthesise{$dq->{type}}
+      ? [ '(', $self->_render($dq), ')' ]
+      : $self->_render($dq));
+}
+
 sub _handle_op_type_binop {
   my ($self, $op_name, $dq) = @_;
   die "${op_name} registered as binary op but args contain "
       .scalar(@{$dq->{args}})." entries"
     unless @{$dq->{args}} == 2;
   [
-    $self->_render($dq->{args}[0]),
+    $self->_maybe_parenthesise($dq->{args}[0]),
     $op_name,
-    $self->_render($dq->{args}[1]),
+    $self->_maybe_parenthesise($dq->{args}[1]),
   ]
 }
 
@@ -202,7 +211,7 @@ sub _handle_op_type_flatten {
   [ '(',
       intersperse(
         $self->_format_keyword($op_name),
-        map $self->_render($_), @arg_final
+        map $self->_maybe_parenthesise($_), @arg_final
       ),
     ')'
   ];
@@ -223,7 +232,7 @@ sub _handle_op_type_between {
   my ($self, $op_name, $dq) = @_;
   my @args = @{$dq->{args}};
   if (@args == 3) {
-    my ($lhs, $rhs1, $rhs2) = (map $self->_render($_), @args);
+    my ($lhs, $rhs1, $rhs2) = (map $self->_maybe_parenthesise($_), @args);
     [ '(', $lhs, $op_name, $rhs1, 'AND', $rhs2, ')' ];
   } elsif (@args == 2 and $args[1]->{type} eq DQ_LITERAL) {
     my ($lhs, $rhs) = (map $self->_render($_), @args);
@@ -248,7 +257,7 @@ sub _handle_op_type_apply {
   };
   [
     "$ident(",
-      intersperse(',', map $self->_render($_), @args),
+      intersperse(',', map $self->_maybe_parenthesise($_), @args),
     ')'
   ]
 }
@@ -304,9 +313,7 @@ sub _render_alias {
   }
   my %parenthesise = map +($_ => 1), DQ_SELECT, DQ_SLICE;
   return [ # XXX not sure this is the right place to detect this
-    ($parenthesise{$dq->{from}{type}}
-      ? [ '(', $self->_render($dq->{from}), ')' ]
-      : $self->_render($dq->{from})),
+    $self->_maybe_parenthesise($dq->{from}),
     $as || ' ',
     $self->_render_identifier({ elements => [ $dq->{to} ] })
   ];
diff --git a/lib/Data/Query/Renderer/SQL/Slice/GenericSubQ.pm b/lib/Data/Query/Renderer/SQL/Slice/GenericSubQ.pm
new file mode 100644
index 0000000..92379af
--- /dev/null
+++ b/lib/Data/Query/Renderer/SQL/Slice/GenericSubQ.pm
@@ -0,0 +1,202 @@
+package Data::Query::Renderer::SQL::Slice::GenericSubQ;
+
+use Data::Query::Constants qw(
+  DQ_SELECT DQ_ALIAS DQ_IDENTIFIER DQ_ORDER DQ_SLICE
+  DQ_WHERE DQ_OPERATOR
+);
+use Moo::Role;
+
+sub _render_slice {
+  my ($self, $dq) = @_;
+  unless ($dq->{order_is_stable}) {
+    die "GenericSubQ limit style requires a stable order";
+  }
+  die "Slice's inner is not a Select"
+    unless (my $orig_select = $dq->{from})->{type} eq DQ_SELECT;
+  my %alias_map;
+  my $gensym_count;
+  my (@inside_select_list, @outside_select_list);
+  my $default_inside_alias;
+  SELECT: foreach my $s (@{$orig_select->{select}}) {
+    my $name;
+    if ($s->{type} eq DQ_ALIAS) {
+      $name = $s->{to};
+      $s = $s->{from};
+    }
+    my $key;
+    if ($s->{type} eq DQ_IDENTIFIER) {
+      if (!$name and @{$s->{elements}} == 2) {
+        $default_inside_alias ||= $s->{elements}[0];
+        if ($s->{elements}[0] eq $default_inside_alias) {
+          $alias_map{join('.',@{$s->{elements}})} = $s;
+          push @inside_select_list, $s;
+          push @outside_select_list, $s;
+          next SELECT;
+        }
+      }
+      $name ||= join('__', @{$s->{elements}});
+      $key = join('.', @{$s->{elements}});
+    } else {
+      die "XXX not implemented yet" unless $name;
+      $key = "$s";
+    }
+    $name ||= sprintf("GENSYM__%03i",++$gensym_count);
+    push @inside_select_list, +{
+      type => DQ_ALIAS,
+      from => $s,
+      to => $name,
+    };
+    push @outside_select_list, $alias_map{$key} = +{
+      type => DQ_IDENTIFIER,
+      elements => [ $name ]
+    };
+  }
+  my $order = $orig_select->{from};
+  my $order_gensym_count;
+  die "Slice's Select not followed by Order but order_is_stable set"
+    unless $order->{type} eq DQ_ORDER;
+  my (@order_nodes, %order_map);
+  while ($order->{type} eq DQ_ORDER) {
+    my $by = $order->{by};
+    if ($by->{type} eq DQ_IDENTIFIER) {
+      $default_inside_alias ||= $by->{elements}[0]
+        if @{$by->{elements}} == 2;
+      $order_map{$by}
+        = $alias_map{join('.', @{$by->{elements}})}
+          ||= do {
+                if (
+                  @{$by->{elements}} == 2
+                  and $by->{elements}[0] eq $default_inside_alias
+                ) {
+                  $by;
+                } else {
+                  my $name = sprintf("ORDER__BY__%03i",++$order_gensym_count);
+                  push @inside_select_list, +{
+                    type => DQ_ALIAS,
+                    from => $by,
+                    to => $name
+                  };
+                  +{
+                    type => DQ_IDENTIFIER,
+                    elements => [ $name ],
+                  };
+                }
+              };
+    } else {
+      die "XXX not implemented yet";
+    }
+    push @order_nodes, $order;
+    $order = $order->{from};
+  }
+  my $inside_select = +{
+    type => DQ_SELECT,
+    select => \@inside_select_list,
+    from => $order,
+  };
+  $default_inside_alias ||= 'me';
+  my $bridge_from = +{
+    type => DQ_ALIAS,
+    to => $default_inside_alias,
+    from => $inside_select,
+  };
+  my $default_inside_from;
+  FIND_FROM: {
+    my @queue = $order;
+    my $cb_map = +{
+      DQ_ALIAS ,=> sub {
+        if ($_[0]->{to} eq $default_inside_alias) {
+          $default_inside_from = $_[0]->{from};
+          no warnings 'exiting';
+          last FIND_FROM;
+        }
+      }
+    };
+    # _scan_nodes from DBIHacks - maybe make this a sub somewhere?
+    while (my $node = shift @queue) {
+      if ($node->{type} and my $cb = $cb_map->{$node->{type}}) {
+        $cb->($node);
+      }
+      push @queue,
+        grep ref($_) eq 'HASH',
+          map +(ref($_) eq 'ARRAY' ? @$_ : $_),
+            @{$node}{grep !/\./, keys %$node};
+    }
+    die "Couldn't figure out where ${default_inside_alias} came from :(";
+  }
+  my $bridge_where = +{
+    type => DQ_WHERE,
+    from => $bridge_from,
+    where => {
+      type => DQ_OPERATOR,
+      operator => {
+        'SQL.Naive' => $dq->{offset} ? 'BETWEEN' : '<'
+      },
+      args => [
+        {
+          type => DQ_SELECT,
+          select => [
+            {
+              type => DQ_OPERATOR,
+              operator => { 'SQL.Naive' => 'apply' },
+              args => [
+                {
+                  type => DQ_IDENTIFIER,
+                  elements => [ 'COUNT' ],
+                },
+                {
+                  type => DQ_IDENTIFIER,
+                  elements => [ '*' ],
+                }
+              ]
+            }
+          ],
+          from => {
+            type => DQ_WHERE,
+            from => {
+              type => DQ_ALIAS,
+              from => $default_inside_from,
+              to => 'rownum__emulation',
+            },
+            where => {
+              type => DQ_OPERATOR,
+              operator => { 'SQL.Naive' => '<' },
+              args => [
+                map +{
+                  type => DQ_IDENTIFIER,
+                  elements => [
+                    $_,
+                    $order_nodes[0]{by}{elements}[-1],
+                  ]
+                }, 'rownum__emulation', $default_inside_alias,
+              ],
+            }
+          },
+        },
+        $dq->{limit},
+        ($dq->{offset} ? ($dq->{offset} : ())),
+      ]
+    },
+  };
+  my $outside_order = $bridge_where;
+  $outside_order = +{
+    type => DQ_ORDER,
+    by => $order_map{$_->{by}},
+    reverse => $_->{reverse},
+    from => $outside_order
+  } for reverse @order_nodes;
+  my $outside_select = +{
+    type => DQ_SELECT,
+    select => (
+      $dq->{preserve_order}
+        ? [
+            @outside_select_list,
+            grep @{$_->{elements}} == 1, @order_map{map $_->{by}, @order_nodes}
+          ]
+        : \@outside_select_list,
+    ),
+    from => $outside_order,
+  };
+  return $self->_render($outside_select);
+}
+
+1;