first whack at GenericSubQ, half works

[dbsrgits/Data-Query.git] / lib / Data / Query / Renderer / SQL / Slice / GenericSubQ.pm

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;