lib/Data/Query/Renderer/SQL/Naive.pm

   1 package Data::Query::Renderer::SQL::Naive;
   2
   3 use strictures 1;
   4 use SQL::ReservedWords;
   5 use Data::Query::Constants qw(
   6   DQ_IDENTIFIER DQ_OPERATOR DQ_VALUE DQ_JOIN DQ_ALIAS
   7 );
   8
   9 sub new {
  10   bless({ %{$_[1]||{}} }, (ref($_[0])||$_[0]))->BUILDALL;
  11 }
  12
  13 sub BUILDALL {
  14   my $self = shift;
  15   $self->{reserved_ident_parts}
  16     ||= (
  17       our $_DEFAULT_RESERVED ||= { map +($_ => 1), SQL::ReservedWords->words }
  18     );
  19   $self->{quote_chars}||=[''];
  20   $self->{simple_ops}||=$self->_default_simple_ops;
  21   return $self;
  22 }
  23
  24 sub _default_simple_ops {
  25   +{
  26     (map +($_ => 'binop'), qw(= > < >= <=) ),
  27     (map +($_ => 'unop'), (qw(NOT)) ),
  28     (map +($_ => 'flatten'), qw(AND OR) ),
  29   }
  30 }
  31
  32 sub render {
  33   my $self = shift;
  34   $self->_flatten_structure($self->_render(@_))
  35 }
  36
  37 sub _flatten_structure {
  38   my ($self, $struct) = @_;
  39   my @bind;
  40   [ do {
  41       my @p = map {
  42         my $r = ref;
  43         if (!$r) { $_ }
  44         elsif ($r eq 'ARRAY') {
  45           my ($sql, @b) = @{$self->_flatten_structure($_)};
  46           push @bind, @b;
  47           $sql;
  48         }
  49         elsif ($r eq 'HASH') { push @bind, $_; () }
  50         else { die "_flatten_structure can't handle ref type $r for $_" }
  51       } @$struct;
  52       join '', map {
  53         ($p[$_], (($p[$_+1]||',') eq ',') ? () : (' '))
  54       } 0 .. $#p;
  55     },
  56     @bind
  57   ];
  58 }
  59
  60 # I present this to permit strange people to easily supply a patch to lc()
  61 # their keywords, as I have heard many desire to do, lest they infect me
  62 # with whatever malady caused this desire by their continued proximity for
  63 # want of such a feature.
  64
  65 sub _format_keyword { $_[1] }
  66
  67 sub _render {
  68   $_[0]->${\"_render_${\(lc($_[1]->{type})||'broken')}"}($_[1]);
  69 }
  70
  71 sub _render_broken {
  72   my ($self, $dq) = @_;
  73   require Data::Dumper::Concise;
  74   die "Broken DQ entry: ".Data::Dumper::Concise::Dumper($dq);
  75 }
  76
  77 sub _render_identifier {
  78   die "Unidentified identifier (SQL can no has \$_)"
  79     unless my @i = @{$_[1]->{elements}};
  80   # handle single or paired quote chars
  81   my ($q1, $q2) = @{$_[0]->{quote_chars}}[0,-1];
  82   my $always_quote = $_[0]->{always_quote};
  83   my $res_check = $_[0]->{reserved_ident_parts};
  84   return [
  85     join
  86       $_[0]->{identifier_sep}||'.',
  87       map +(
  88         $_ eq '*' # Yes, this means you can't have a column just called '*'.
  89           ? $_    # Yes, this is a feature. Go shoot the DBA if he disagrees.
  90           : ( # reserved are stored uc, quote if non-word
  91               $always_quote || $res_check->{+uc} || /\W/
  92                 ? $q1.$_.$q2
  93                 : $_
  94             )
  95       ), @i
  96   ];
  97 }
  98
  99 sub _render_value {
 100   [ '?', $_[1] ];
 101 }
 102
 103 sub _operator_type { 'SQL.Naive' }
 104
 105 sub _render_operator {
 106   my ($self, $dq) = @_;
 107   my $op = $dq->{operator};
 108   unless (exists $op->{$self->_operator_type}) {
 109     $op->{$self->_operator_type} = $self->_convert_op($dq);
 110   }
 111   if (my $op_type = $self->{simple_ops}{my $op_name = $op->{$self->_operator_type}}) {
 112     return $self->${\"_handle_op_type_${op_type}"}($op_name, $dq);
 113   }
 114   die "Couldn't render operator ".$op->{$self->_operator_type};
 115 }
 116
 117 sub _handle_op_type_binop {
 118   my ($self, $op_name, $dq) = @_;
 119   die "${op_name} registered as binary op but args contain "
 120       .scalar(@{$dq->{args}})." entries"
 121     unless @{$dq->{args}} == 2;
 122   [
 123     $self->_render($dq->{args}[0]),
 124     $op_name,
 125     $self->_render($dq->{args}[1]),
 126   ]
 127 }
 128
 129 sub _handle_op_type_unop {
 130   my ($self, $op_name, $dq) = @_;
 131   die "${op_name} registered as unary op but args contain "
 132       .scalar(@{$dq->{args}})." entries"
 133     unless @{$dq->{args}} == 1;
 134   [
 135     [ $op_name ],
 136     $self->_render($dq->{args}[0]),
 137   ]
 138 }
 139
 140 sub _handle_op_type_flatten {
 141   my ($self, $op_name, $dq) = @_;
 142   my @argq = @{$dq->{args}};
 143   my @arg_final;
 144   while (my $arg = shift @argq) {
 145
 146     unless ($arg->{type} eq DQ_OPERATOR) {
 147       push @arg_final, $arg;
 148       next;
 149     }
 150
 151     my $op = $arg->{operator};
 152     unless (exists $op->{$self->_operator_type}) {
 153       $op->{$self->_operator_type} = $self->_convert_op($arg);
 154     }
 155
 156     if ($op->{$self->_operator_type} eq $op_name) {
 157       unshift @argq, @{$arg->{args}};
 158     } else {
 159       push @arg_final, $arg;
 160     }
 161   }
 162   my @sql = ('(', map +($self->_render($_), $op_name), @arg_final);
 163   $sql[-1] = ')'; # replace final AND or whatever with )
 164   \@sql;
 165 }
 166
 167 sub _convert_op {
 168   my ($self, $dq) = @_;
 169   if (my $perl_op = $dq->{'operator'}->{'Perl'}) {
 170     for ($perl_op) {
 171       $_ eq '==' and return '=';
 172       $_ eq 'eq' and return '=';
 173       $_ eq '!' and return 'NOT';
 174     }
 175     return uc $perl_op; # hope!
 176   }
 177   die "Can't convert non-perl op yet";
 178 }
 179
 180 sub _render_select {
 181   my ($self, $dq) = @_;
 182   die "Empty select list" unless @{$dq->{select}};
 183
 184   # it is, in fact, completely valid for there to be nothing for us
 185   # to project from since many databases handle 'SELECT 1;' fine
 186
 187   my @select = map [
 188     ($_->{type} eq DQ_ALIAS
 189       ? $self->_render_alias($_, 'AS')
 190       : $self->_render($_)
 191     ),
 192    ','
 193   ], @{$dq->{select}};
 194
 195   # we put the commas inside the [] for each entry as a hint to the pretty
 196   # printer downstream so now we need to eliminate the comma from the last
 197   # entry - we know there always is one due to the die guard at the top
 198
 199   pop @{$select[-1]};
 200
 201   return [
 202     $self->_format_keyword('SELECT'),
 203     \@select,
 204     # if present this may be a bare FROM, a FROM+WHERE, or a FROM+WHERE+GROUP
 205     # since we're the SELECT and therefore always come first, we don't care.
 206     ($dq->{from}
 207        ? ($self->_format_keyword('FROM'), @{$self->_render($dq->{from})})
 208        : ()
 209     )
 210   ];
 211 }
 212
 213 sub _render_alias {
 214   my ($self, $dq, $as) = @_;
 215   # FROM foo foo -> FROM foo
 216   # FROM foo.bar bar -> FROM foo.bar
 217   if ($dq->{alias}{type} eq DQ_IDENTIFIER) {
 218     if ($dq->{alias}{elements}[-1] eq $dq->{as}) {
 219       return $self->_render($dq->{alias});
 220     }
 221   }
 222   return [
 223     $self->_render($dq->{alias}),
 224     $as || ' ',
 225     $self->_render_identifier({ elements => [ $dq->{as} ] })
 226   ];
 227 }
 228
 229 sub _render_literal {
 230   my ($self, $dq) = @_;
 231   unless ($dq->{subtype} eq 'SQL') {
 232     die "Can't render non-SQL literal";
 233   }
 234   return [
 235     $dq->{literal},
 236   ];
 237 }
 238
 239 sub _render_join {
 240   my ($self, $dq) = @_;
 241   my ($left, $right) = @{$dq->{join}};
 242   die "No support for ON yet" if $dq->{on};
 243   die "No support for LEFT/RIGHT yet" if $dq->{outer};
 244   [ $self->_render($left), ',', $self->_render($right) ];
 245 }
 246
 247 1;