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' => $dq->{offset} ? 'BETWEEN' : '<'
 133       },
 134       args => [
 135         {
 136           type => DQ_SELECT,
 137           select => [
 138             {
 139               type => DQ_OPERATOR,
 140               operator => { 'SQL.Naive' => 'apply' },
 141               args => [
 142                 {
 143                   type => DQ_IDENTIFIER,
 144                   elements => [ 'COUNT' ],
 145                 },
 146                 {
 147                   type => DQ_IDENTIFIER,
 148                   elements => [ '*' ],
 149                 }
 150               ]
 151             }
 152           ],
 153           from => {
 154             type => DQ_WHERE,
 155             from => {
 156               type => DQ_ALIAS,
 157               from => $default_inside_from,
 158               to => 'rownum__emulation',
 159             },
 160             where => {
 161               type => DQ_OPERATOR,
 162               operator => { 'SQL.Naive' => '<' },
 163               args => [
 164                 map +{
 165                   type => DQ_IDENTIFIER,
 166                   elements => [
 167                     $_,
 168                     $order_nodes[0]{by}{elements}[-1],
 169                   ]
 170                 }, 'rownum__emulation', $default_inside_alias,
 171               ],
 172             }
 173           },
 174         },
 175         $dq->{limit},
 176         ($dq->{offset} ? ($dq->{offset} : ())),
 177       ]
 178     },
 179   };
 180   my $outside_order = $bridge_where;
 181   $outside_order = +{
 182     type => DQ_ORDER,
 183     by => $order_map{$_->{by}},
 184     reverse => $_->{reverse},
 185     from => $outside_order
 186   } for reverse @order_nodes;
 187   my $outside_select = +{
 188     type => DQ_SELECT,
 189     select => (
 190       $dq->{preserve_order}
 191         ? [
 192             @outside_select_list,
 193             grep @{$_->{elements}} == 1, @order_map{map $_->{by}, @order_nodes}
 194           ]
 195         : \@outside_select_list,
 196     ),
 197     from => $outside_order,
 198   };
 199   return $self->_render($outside_select);
 200 }
 201
 202 1;