From: Matt S Trout <mst@shadowcat.co.uk>
Date: Thu, 11 Oct 2012 12:01:12 +0000 (+0100)
Subject: beginnings of declarative code
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=aad6ee1b9034ca9f7cb54cb7d29984c76e9906f0;p=dbsrgits%2FData-Query.git

beginnings of declarative code
---

diff --git a/lib/Data/Query/ExprDeclare.pm b/lib/Data/Query/ExprDeclare.pm
new file mode 100644
index 0000000..0a1bcaa
--- /dev/null
+++ b/lib/Data/Query/ExprDeclare.pm
@@ -0,0 +1,95 @@
+package Data::Query::ExprDeclare;
+
+use strictures;
+use Data::Query::ExprBuilder::Identifier;
+use Data::Query::ExprHelpers;
+use Data::Query::Constants;
+use Safe::Isa;
+
+use base qw(Exporter);
+
+our @EXPORT = qw(expr SELECT AS FROM BY JOIN ON LEFT);
+
+sub expr (&) {
+  _run_expr($_[0])->{expr};
+}
+
+sub _run_expr {
+  local $_ = Data::Query::ExprBuilder::Identifier->new({
+    expr => Identifier(),
+  });
+  $_[0]->();
+}
+
+sub _value {
+  ref($_[0]) ? $_[0]->{expr} : perl_scalar_value($_[0])
+}
+
+sub AS {
+  my $as = shift;
+  (bless(\$as, 'LIES::AS'), @_);
+}
+
+sub SELECT (&;@) {
+  my @select = map _value($_), _run_expr(shift);
+  my @final;
+  while (@select) {
+    my $e = shift @select;
+    push @final,
+      (ref($select[0]) eq 'LIES::AS'
+        ? Alias(${shift(@select)}, $e)
+        : $e
+     );
+  }
+      
+  return Select(\@final, $_[0]);
+}
+
+sub BY (&;@) { @_ }
+
+sub FROM (&;@) {
+  my @from = _run_expr(shift);
+  my $from_dq = do {
+    if (@from == 2 and ref($from[1]) eq 'LIES::AS') {
+      Alias(${$from[1]}, _value($from[0]))
+    } elsif (@from == 1) {
+      _value($from[0]);
+    }
+  };
+  while ($_[0] and is_Join($_[0])) {
+    $from_dq = { %{+shift}, left => $from_dq };
+  }
+  return $from_dq;
+  die "Huh?"
+}
+
+sub LEFT {
+  my ($join, @rest) = @_;
+  die "LEFT used as modifier on non-join ${join}"
+    unless is_Join($join);
+  return +{ %$join, outer => 'LEFT' }, @rest;
+}
+
+sub JOIN (&;@) {
+  my $join = FROM(\&{+shift});
+  my $on = do {
+    if ($_[0]->$_isa('LIES::ON')) {
+      ${+shift}
+    } else {
+      undef
+    }
+  };
+  Join(undef, $join, $on), @_;
+}
+
+sub ON (&;@) {
+  my $on = _value(_run_expr(shift));
+  return bless(\$on, 'LIES::ON'), @_;
+}
+
+sub WHERE (&;@) {
+  my $w = shift;
+  return Where(_value(_run_expr($w))), @_;
+}
+
+1;
diff --git a/t/example.t b/t/example.t
new file mode 100644
index 0000000..f59dd98
--- /dev/null
+++ b/t/example.t
@@ -0,0 +1,30 @@
+use strictures;
+use Data::Query::ExprDeclare;
+use Data::Query::Renderer::SQL::Naive;
+use Devel::Dwarn;
+
+my $renderer = Data::Query::Renderer::SQL::Naive->new;
+
+sub render_expr {
+  my ($sql, @bindp) = @{$renderer->render($_[0])};
+  ($sql, map $_->{value}, @bindp);
+}
+
+DwarnL render_expr(SELECT { $_->foo, "bar" });
+DwarnL render_expr(SELECT { $_->foo, "bar" } FROM { $_->baz });
+DwarnL render_expr(SELECT { $_->foo } FROM { $_->baz, AS('quux') });
+DwarnL render_expr(
+  SELECT { $_->cd->name } FROM { $_->cds, AS('cd') } JOIN { $_->artists }
+);
+DwarnL render_expr(
+  SELECT { $_->cd->name }
+  FROM { $_->cds, AS 'cd' }
+  JOIN { $_->artists, AS 'artist' }
+    ON { $_->cd->artistid eq $_->artist->id }
+);
+DwarnL render_expr(
+  SELECT { $_->artist->name }
+  FROM { $_->artists, AS 'artist' }
+  LEFT JOIN { $_->cds, AS 'cd' }
+         ON { $_->cd->artistid eq $_->artist->id }
+);