lib/Data/Query/Renderer/SQL/Slice/GenericSubQ.pm

   1 package Data::Query::Renderer::SQL::Slice::GenericSubQ;
   2
   3 use Data::Query::Constants qw(
   4   DQ_SELECT DQ_ALIAS DQ_IDENTIFIER DQ_ORDER DQ_SLICE
   5   DQ_WHERE DQ_OPERATOR
   6 );
   7 use Moo::Role;
   8
   9 sub _render_slice {
  10   my ($self, $dq) = @_;
  11   unless ($dq->{order_is_stable}) {
  12     die "GenericSubQ limit style requires a stable order";
  13   }
  14   die "Slice's inner is not a Select"
  15     unless (my $orig_select = $dq->{from})->{type} eq DQ_SELECT;
  16   my %alias_map;
  17   my $gensym_count;
  18   my (@inside_select_list, @outside_select_list);
  19   my $default_inside_alias;
  20   SELECT: foreach my $s (@{$orig_select->{select}}) {
  21     my $name;
  22     if ($s->{type} eq DQ_ALIAS) {
  23       $name = $s->{to};
  24       $s = $s->{from};
  25     }
  26     my $key;
  27     if ($s->{type} eq DQ_IDENTIFIER) {
  28       if (!$name and @{$s->{elements}} == 2) {
  29         $default_inside_alias ||= $s->{elements}[0];
  30         if ($s->{elements}[0] eq $default_inside_alias) {
  31           $alias_map{join('.',@{$s->{elements}})} = $s;
  32           push @inside_select_list, $s;
  33           push @outside_select_list, $s;
  34           next SELECT;
  35         }
  36       }
  37       $name ||= join('__', @{$s->{elements}});
  38       $key = join('.', @{$s->{elements}});
  39     } else {
  40       die "XXX not implemented yet" unless $name;
  41       $key = "$s";
  42     }
  43     $name ||= sprintf("GENSYM__%03i",++$gensym_count);
  44     push @inside_select_list, +{
  45       type => DQ_ALIAS,
  46       from => $s,
  47       to => $name,
  48     };
  49     push @outside_select_list, $alias_map{$key} = +{
  50       type => DQ_IDENTIFIER,
  51       elements => [ $name ]
  52     };
  53   }
  54   my $order = $orig_select->{from};
  55   my $order_gensym_count;
  56   die "Slice's Select not followed by Order but order_is_stable set"
  57     unless $order->{type} eq DQ_ORDER;
  58   my (@order_nodes, %order_map);
  59   while ($order->{type} eq DQ_ORDER) {
  60     my $by = $order->{by};
  61     if ($by->{type} eq DQ_IDENTIFIER) {
  62       $default_inside_alias ||= $by->{elements}[0]
  63         if @{$by->{elements}} == 2;
  64       $order_map{$by}
  65         = $alias_map{join('.', @{$by->{elements}})}
  66           ||= do {
  67                 if (
  68                   @{$by->{elements}} == 2
  69                   and $by->{elements}[0] eq $default_inside_alias
  70                 ) {
  71                   $by;
  72                 } else {
  73                   my $name = sprintf("ORDER__BY__%03i",++$order_gensym_count);
  74                   push @inside_select_list, +{
  75                     type => DQ_ALIAS,
  76                     from => $by,
  77                     to => $name
  78                   };
  79                   +{
  80                     type => DQ_IDENTIFIER,
  81                     elements => [ $name ],
  82                   };
  83                 }
  84               };
  85     } else {
  86       die "XXX not implemented yet";
  87     }
  88     push @order_nodes, $order;
  89     $order = $order->{from};
  90   }
  91   my $inside_select = +{
  92     type => DQ_SELECT,
  93     select => \@inside_select_list,
  94     from => $order,
  95   };
  96   $default_inside_alias ||= 'me';
  97   my $bridge_from = +{
  98     type => DQ_ALIAS,
  99     to => $default_inside_alias,
 100     from => $inside_select,
 101   };
 102   my $default_inside_from;
 103   FIND_FROM: {
 104     my @queue = $order;
 105     my $cb_map = +{
 106       DQ_ALIAS ,=> sub {
 107         if ($_[0]->{to} eq $default_inside_alias) {
 108           $default_inside_from = $_[0]->{from};
 109           no warnings 'exiting';
 110           last FIND_FROM;
 111         }
 112       }
 113     };
 114     # _scan_nodes from DBIHacks - maybe make this a sub somewhere?
 115     while (my $node = shift @queue) {
 116       if ($node->{type} and my $cb = $cb_map->{$node->{type}}) {
 117         $cb->($node);
 118       }
 119       push @queue,
 120         grep ref($_) eq 'HASH',
 121           map +(ref($_) eq 'ARRAY' ? @$_ : $_),
 122             @{$node}{grep !/\./, keys %$node};
 123     }
 124     die "Couldn't figure out where ${default_inside_alias} came from :(";
 125   }
 126   my $bridge_where = +{
 127     type => DQ_WHERE,
 128     from => $bridge_from,
 129     where => {
 130       type => DQ_OPERATOR,
 131       operator => {
 132         'SQL.Naive' => (
 133           $dq->{offset}
 134             ? 'BETWEEN'
 135             : $order_nodes[0]{reverse} ? '>' : '<'
 136         ),
 137       },
 138       args => [
 139         {
 140           type => DQ_SELECT,
 141           select => [
 142             {
 143               type => DQ_OPERATOR,
 144               operator => { 'SQL.Naive' => 'apply' },
 145               args => [
 146                 {
 147                   type => DQ_IDENTIFIER,
 148                   elements => [ 'COUNT' ],
 149                 },
 150                 {
 151                   type => DQ_IDENTIFIER,
 152                   elements => [ '*' ],
 153                 }
 154               ]
 155             }
 156           ],
 157           from => {
 158             type => DQ_WHERE,
 159             from => {
 160               type => DQ_ALIAS,
 161               from => $default_inside_from,
 162               to => 'rownum__emulation',
 163             },
 164             where => {
 165               type => DQ_OPERATOR,
 166               operator => {
 167                 'SQL.Naive' => $order_nodes[0]{reverse} ? '>' : '<'
 168               },
 169               args => [
 170                 map +{
 171                   type => DQ_IDENTIFIER,
 172                   elements => [
 173                     $_,
 174                     $order_nodes[0]{by}{elements}[-1],
 175                   ]
 176                 }, 'rownum__emulation', $default_inside_alias,
 177               ],
 178             }
 179           },
 180         },
 181         ($dq->{offset}
 182            ? ($dq->{offset},
 183                { %{$dq->{limit}},
 184                  value => $dq->{offset}{value} + $dq->{limit}{value} - 1
 185                }
 186              )
 187            : ($dq->{limit})
 188         ),
 189       ]
 190     },
 191   };
 192   my $outside_order = $bridge_where;
 193   $outside_order = +{
 194     type => DQ_ORDER,
 195     by => $order_map{$_->{by}},
 196     reverse => $_->{reverse},
 197     from => $outside_order
 198   } for reverse @order_nodes;
 199   my $outside_select = +{
 200     type => DQ_SELECT,
 201     select => (
 202       $dq->{preserve_order}
 203         ? [
 204             @outside_select_list,
 205             grep @{$_->{elements}} == 1, @order_map{map $_->{by}, @order_nodes}
 206           ]
 207         : \@outside_select_list,
 208     ),
 209     from => $outside_order,
 210   };
 211   return $self->_render($outside_select);
 212 }
 213
 214 1;