From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 16 Oct 2010 01:51:57 +0000 (+0100)
Subject: introduce SELECT capability and skeleton test
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9c8fc055bf3cdc5965eb86e5be78e636d51b4da2;p=dbsrgits%2FData-Query.git

introduce SELECT capability and skeleton test
---

diff --git a/lib/Data/Query/Constants.pm b/lib/Data/Query/Constants.pm
index 1a9debc..7730cde 100644
--- a/lib/Data/Query/Constants.pm
+++ b/lib/Data/Query/Constants.pm
@@ -8,6 +8,7 @@ use constant +{
     DQ_IDENTIFIER => 'Identifier',
     DQ_OPERATOR => 'Operator',
     DQ_VALUE => 'Value',
+    DQ_SELECT => 'Select',
   ))
 };
 
diff --git a/lib/Data/Query/ExprHelpers.pm b/lib/Data/Query/ExprHelpers.pm
index 1ba349e..d194313 100644
--- a/lib/Data/Query/ExprHelpers.pm
+++ b/lib/Data/Query/ExprHelpers.pm
@@ -1,17 +1,17 @@
 package Data::Query::ExprHelpers;
 
 use strictures 1;
-use Data::Query::Constants qw(DQ_VALUE DQ_OPERATOR);
+use Data::Query::Constants qw(DQ_VALUE DQ_OPERATOR DQ_IDENTIFIER);
 
 use base qw(Exporter);
 
-our @EXPORT_OK = qw(perl_scalar_value perl_operator);
+our @EXPORT_OK = qw(perl_scalar_value perl_operator identifier);
 
 sub perl_scalar_value {
   +{
-      type => DQ_VALUE,
-      subtype => { Perl => 'Scalar' },
-      value => $_[0]
+    type => DQ_VALUE,
+    subtype => { Perl => 'Scalar' },
+    value => $_[0]
   }
 }
 
@@ -24,4 +24,11 @@ sub perl_operator {
   }
 }
 
+sub identifier {
+  +{
+    type => DQ_IDENTIFIER,
+    elements => [ @_ ]
+  }
+}
+
 1;
diff --git a/lib/Data/Query/Renderer/SQL/Naive.pm b/lib/Data/Query/Renderer/SQL/Naive.pm
index cbfc1e9..d8c5870 100644
--- a/lib/Data/Query/Renderer/SQL/Naive.pm
+++ b/lib/Data/Query/Renderer/SQL/Naive.pm
@@ -48,6 +48,13 @@ sub _flatten_structure {
   } @$struct), @bind ];
 }
 
+# I present this to permit strange people to easily supply a patch to lc()
+# their keywords, as I have heard many desire to do, lest they infect me
+# with whatever malady caused this desire by their continued proximity for
+# want of such a feature.
+
+sub _format_keyword { $_[1] }
+
 sub _render {
   $_[0]->${\"_render_${\lc($_[1]->{type})}"}($_[1]);
 }
@@ -154,5 +161,36 @@ sub _convert_op {
   }
   die "Can't convert non-perl op yet";
 }
-  
+
+sub _render_select {
+  my ($self, $dq) = @_;
+  die "Empty select list" unless @{$dq->{select}};
+
+  # it is, in fact, completely valid for there to be nothing for us
+  # to project from since many databases handle 'SELECT 1;' fine
+
+  my @select = map {
+    # we should perhaps validate that what we've been handed
+    # is an expression and possibly an identifier - at least a
+    # debugging mode that does such is almost certainly worthwhile;
+    # but for present I'm focusing on making this work.
+    my $e = $self->_render($_->{expr});
+    $_->{name} ? [ $e, 'AS', $self->_render($_->{name}), ',' ] : [ $e, ',' ]
+  } @{$dq->{select}};
+
+  # we put the commas inside the [] for each entry as a hint to the pretty
+  # printer downstreamso now we need to eliminate the comma from the last
+  # entry - we know there always is one due to the die guard at the top
+
+  pop @{$select[-1]};
+
+  return [
+    $self->_format_keyword('SELECT'),
+    \@select,
+    # if present this may be a bare FROM, a FROM+WHERE, or a FROM+WHERE+GROUP
+    # since we're the SELECT and therefore always come first, we don't care.
+    $dq->{from} ? @{$self->_render($dq->{from})} : ()
+  ];
+}
+
 1;
diff --git a/t/expr.include b/t/expr.include
index f124223..0521b29 100644
--- a/t/expr.include
+++ b/t/expr.include
@@ -1,5 +1,7 @@
+use strictures 1;
 use Data::Query::ExprBuilder::Identifier;
-use Data::Query::Constants qw(DQ_IDENTIFIER DQ_OPERATOR DQ_VALUE);
+use Data::Query::Constants qw(DQ_SELECT);
+use Data::Query::ExprHelpers qw(perl_scalar_value identifier);
 
 sub expr (&) {
   _mk_expr($_[0]);
@@ -7,12 +9,42 @@ sub expr (&) {
 
 sub _mk_expr {
   local $_ = Data::Query::ExprBuilder::Identifier->new({
-    expr => {
-      type => DQ_IDENTIFIER,
-      elements => [],
-    },
+    expr => identifier()
   });
   $_[0]->()->{expr};
 }
 
+sub AS {
+  my $as = shift;
+  (bless(\$as, 'LIES::AS'), @_);
+}
+
+sub SELECT (&;@) {
+  my @select = map +(
+    ref()
+      ? $_
+      : { expr => perl_scalar_value($_) }
+  ), do {
+    local $_ = Data::Query::ExprBuilder::Identifier->new({
+      expr => identifier()
+    });
+    $_[0]->();
+  };
+  my @final;
+  while (@select) {
+    my $e = shift @select;
+    my $res = push @final, +{ expr => $e->{expr} };
+    if (ref($select[0]) eq 'LIES::AS') {
+      $res->{name} = identifier(shift @select);
+    }
+  }
+      
+  return +{
+    expr => {
+      type => DQ_SELECT,
+      select => \@final
+    },
+  };
+}
+
 1;
diff --git a/t/sql.t b/t/sql.t
index 64e2f2c..57cb03b 100644
--- a/t/sql.t
+++ b/t/sql.t
@@ -3,6 +3,7 @@ use Test::More qw(no_plan);
 
 use Devel::Dwarn;
 use Data::Query::Renderer::SQL::Naive;
+use Data::Query::ExprHelpers qw(perl_scalar_value);
 
 BEGIN { require 't/expr.include' }
 
@@ -91,3 +92,13 @@ expr_sql_is { ($_->foo == 1) & ($_->bar eq "foo") & ($_->baz > 3) }
 expr_sql_is { !$_->foo }
   [ "NOT foo" ],
   "Unary expression ok";
+
+expr_sql_is { SELECT { $_->foo } }
+  [ "SELECT foo" ],
+  "Simple identifier";
+
+expr_sql_is { SELECT { $_->foo, 1 } }
+  # the extra space here is a little icky but Naive's _flatten_structure
+  # will need rewriting to fix it - commit bits available if you do it first
+  [ "SELECT foo , ?", perl_scalar_value(1) ],
+  "Identifier and literal";