basic expression rendering for SQL::Naive

diff --git a/lib/Data/Query/Renderer/SQL/Naive.pm b/lib/Data/Query/Renderer/SQL/Naive.pm
new file mode 100644 (file)
index 0000000..f44fb54
--- /dev/null
+++ b/lib/Data/Query/Renderer/SQL/Naive.pm
@@ -0,0 +1,156 @@
+package Data::Query::Renderer::SQL::Naive;
+
+use strictures 1;
+use SQL::ReservedWords;
+use Data::Query::Constants qw(DQ_IDENTIFIER DQ_OPERATOR DQ_VALUE);
+
+sub new {
+  bless({ %{$_[1]||{}} }, (ref($_[0])||$_[0]))->BUILDALL;
+}
+
+sub BUILDALL {
+  my $self = shift;
+  $self->{reserved_ident_parts}
+    ||= (
+      our $_DEFAULT_RESERVED ||= { map +($_ => 1), SQL::ReservedWords->words }
+    );
+  $self->{quote_chars}||=[''];
+  $self->{simple_ops}||=$self->_default_simple_ops;
+  return $self;
+}
+
+sub _default_simple_ops {
+  +{
+    (map +($_ => 'binop'), qw(= > < >= <=) ),
+    (map +($_ => 'unop'), (qw(NOT)) ),
+    (map +($_ => 'flatten'), qw(AND OR) ),
+  }
+}
+
+sub render {
+  my $self = shift;
+  $self->_flatten_structure($self->_render(@_))
+}
+
+sub _flatten_structure {
+  my ($self, $struct) = @_;
+  my @bind;
+  [ (join ' ', map {
+    my $r = ref;
+    if (!$r) { $_ }
+    elsif ($r eq 'ARRAY') {
+      my ($sql, @b) = @{$self->_flatten_structure($_)};
+      push @bind, @b;
+      $sql;
+    }
+    elsif ($r eq 'HASH') { push @bind, $_; () }
+    else { die "_flatten_structure can't handle ref type $r for $_" }
+  } @$struct), @bind ];
+}
+
+sub _render {
+  $_[0]->${\"_render_${\lc($_[1]->{type})}"}($_[1]);
+}
+
+sub _render_identifier {
+  die "Unidentified identifier (SQL can no has \$_)"
+    unless my @i = @{$_[1]->{elements}};
+  # handle single or paired quote chars
+  my ($q1, $q2) = @{$_[0]->{quote_chars}}[0,-1];
+  my $always_quote = $_[0]->{always_quote};
+  my $res_check = $_[0]->{reserved_ident_parts};
+  return [
+    join
+      $_[0]->{identifier_sep}||'.',
+      map +(
+        $_ eq '*' # Yes, this means you can't have a column just called '*'.
+          ? $_    # Yes, this is a feature. Go shoot the DBA if he disagrees.
+          : ( # reserved are stored uc, quote if non-word
+              $always_quote || $res_check->{+uc} || /\W/
+                ? $q1.$_.$q2
+                : $_
+            )
+      ), @i
+  ];
+}
+
+sub _render_value {
+  [ '?', $_[1] ];
+}
+
+sub _render_operator {
+  my ($self, $dq) = @_;
+  my $op = $dq->{operator};
+  unless (exists $op->{'SQL.Naive'}) {
+    $op->{'SQL.Naive'} = $self->_convert_op($dq);
+  }
+  if (my $op_type = $self->{simple_ops}{my $op_name = $op->{'SQL.Naive'}}) {
+    return $self->${\"_handle_op_type_${op_type}"}($op_name, $dq);
+  }
+  die "Couldn't render operator ".$op->{'SQL.Naive'};
+}
+
+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]),
+    $op_name,
+    $self->_render($dq->{args}[1]),
+  ]
+}
+
+sub _handle_op_type_unop {
+  my ($self, $op_name, $dq) = @_;
+  die "${op_name} registered as unary op but args contain "
+      .scalar(@{$dq->{args}})." entries"
+    unless @{$dq->{args}} == 1;
+  [
+    [ $op_name ],
+    $self->_render($dq->{args}[0]),
+  ]
+}
+
+sub _handle_op_type_flatten {
+  my ($self, $op_name, $dq) = @_;
+  my @argq = @{$dq->{args}};
+  my @arg_final;
+  while (my $arg = shift @argq) {
+
+    unless ($arg->{type} eq DQ_OPERATOR) {
+      push @arg_final, $arg;
+      next;
+    }
+
+    my $op = $arg->{operator};
+    unless (exists $op->{'SQL.Naive'}) {
+      $op->{'SQL.Naive'} = $self->_convert_op($arg);
+    }
+  
+    if ($op->{'SQL.Naive'} eq $op_name) {
+      unshift @argq, @{$arg->{args}};
+    } else {
+      push @arg_final, $arg;
+    }
+  }
+  my @sql = ('(', map +($self->_render($_), $op_name), @arg_final);
+  $sql[-1] = ')'; # replace final AND or whatever with )
+  \@sql;
+}
+
+sub _convert_op {
+  my ($self, $dq) = @_;
+  if (my $perl_op = $dq->{'operator'}->{'Perl'}) {
+    for ($perl_op) {
+      $_ eq '==' and return '=';
+      $_ eq 'eq' and return '=';
+      $_ eq '!' and return 'NOT';
+    }
+    return uc $perl_op; # hope!
+  }
+  die "Can't convert non-perl op yet";
+}
+  
+1;

diff --git a/t/expr.include b/t/expr.include
new file mode 100644 (file)
index 0000000..f124223
--- /dev/null
+++ b/t/expr.include
@@ -0,0 +1,18 @@
+use Data::Query::ExprBuilder::Identifier;
+use Data::Query::Constants qw(DQ_IDENTIFIER DQ_OPERATOR DQ_VALUE);
+
+sub expr (&) {
+  _mk_expr($_[0]);
+}
+
+sub _mk_expr {
+  local $_ = Data::Query::ExprBuilder::Identifier->new({
+    expr => {
+      type => DQ_IDENTIFIER,
+      elements => [],
+    },
+  });
+  $_[0]->()->{expr};
+}
+
+1;

diff --git a/t/sql.t b/t/sql.t
new file mode 100644 (file)
index 0000000..64e2f2c
--- /dev/null
+++ b/t/sql.t
@@ -0,0 +1,93 @@
+use strictures 1;
+use Test::More qw(no_plan);
+
+use Devel::Dwarn;
+use Data::Query::Renderer::SQL::Naive;
+
+BEGIN { require 't/expr.include' }
+
+my $rend = Data::Query::Renderer::SQL::Naive->new({ quote_chars => [ "'" ] });
+
+sub expr_sql_is (&;@) {
+  my $sub = shift;
+  @_
+    ? is_deeply($rend->render(_mk_expr($sub)), @_)
+    : ::Dwarn($rend->render(_mk_expr($sub)));
+}
+
+expr_sql_is { $_->foo }
+  [ 'foo' ],
+  "Simple identifier -> SQL";
+
+expr_sql_is { $_->group }
+  [ q{'group'} ],
+  "Simple identifier needing quoting -> SQL";
+
+expr_sql_is { $_->foo->group }
+  [ q{foo.'group'} ],
+  "Complex identifier -> SQL";
+
+expr_sql_is { $_->foo == 1 }
+  [
+    "foo = ?",
+    {
+      subtype => {
+        Perl => "Scalar"
+      },
+      type => "Value",
+      value => 1
+    }
+  ],
+  "Simple expression -> SQL";
+
+expr_sql_is { ($_->foo == 1) & ($_->bar eq "foo") }
+  [
+    "( foo = ? AND bar = ? )",
+    {
+      subtype => {
+        Perl => "Scalar"
+      },
+      type => "Value",
+      value => 1
+    },
+    {
+      subtype => {
+        Perl => "Scalar"
+      },
+      type => "Value",
+      value => "foo"
+    }
+  ],
+  "Compound expression -> SQL";
+
+
+expr_sql_is { ($_->foo == 1) & ($_->bar eq "foo") & ($_->baz > 3) }
+  [
+    "( foo = ? AND bar = ? AND baz > ? )",
+    {
+      subtype => {
+        Perl => "Scalar"
+      },
+      type => "Value",
+      value => 1
+    },
+    {
+      subtype => {
+        Perl => "Scalar"
+      },
+      type => "Value",
+      value => "foo"
+    },
+    {
+      subtype => {
+        Perl => "Scalar"
+      },
+      type => "Value",
+      value => 3
+    }
+  ],
+  "Flatten expression ok";
+
+expr_sql_is { !$_->foo }
+  [ "NOT foo" ],
+  "Unary expression ok";