From: Matt S Trout Date: Sat, 14 Aug 2010 21:02:06 +0000 (+0100) Subject: basic expression rendering for SQL::Naive X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=515523bce5af78d689b6415b6c7aec02b2d4e887;hp=d68bc999eebe149828979ea280173b6e4dd6453d;p=dbsrgits%2FData-Query.git 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 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 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 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";