add scan_dq_nodes helper

[dbsrgits/Data-Query.git] / lib / Data / Query / ExprHelpers.pm

diff --git a/lib/Data/Query/ExprHelpers.pm b/lib/Data/Query/ExprHelpers.pm
index d194313..399a8e2 100644 (file)
--- a/lib/Data/Query/ExprHelpers.pm
+++ b/lib/Data/Query/ExprHelpers.pm
@@ -1,17 +1,23 @@
 package Data::Query::ExprHelpers;
 
 use strictures 1;
-use Data::Query::Constants qw(DQ_VALUE DQ_OPERATOR DQ_IDENTIFIER);
+use Data::Query::Constants;
 
 use base qw(Exporter);
 
-our @EXPORT_OK = qw(perl_scalar_value perl_operator identifier);
+our @EXPORT = qw(
+  perl_scalar_value perl_operator Literal Identifier compose intersperse
+  scan_dq_nodes
+);
+
+sub intersperse { my $i = shift; my @i = map +($_, $i), @_; pop @i; @i }
 
 sub perl_scalar_value {
   +{
     type => DQ_VALUE,
     subtype => { Perl => 'Scalar' },
-    value => $_[0]
+    value => $_[0],
+    $_[1] ? (value_meta => $_[1]) : ()
   }
 }
 
@@ -24,10 +30,114 @@ sub perl_operator {
   }
 }
 
-sub identifier {
-  +{
+my %map = (
+  Join => [ qw(left right on outer) ],
+  Alias => [ qw(to from) ],
+  Operator => [ qw(operator args) ],
+  Select => [ qw(select from) ],
+  Where => [ qw(where from) ],
+  Order => [ qw(by reverse nulls from) ],
+  Group => [ qw(by from) ],
+  Delete => [ qw(where target) ],
+  Update => [ qw(set where target) ],
+  Insert => [ qw(names values target returning) ],
+  Slice => [ qw(offset limit from) ],
+);
+
+sub Literal {
+  my $subtype = shift;
+  if (ref($_[0])) {
+    return +{
+      type => DQ_LITERAL,
+      subtype => $subtype,
+      parts => $_[0],
+    };
+  }
+  return +{
+    type => DQ_LITERAL,
+    subtype => $subtype,
+    literal => $_[0],
+    ($_[1] ? (values => $_[1]) : ())
+  };
+}
+
+sub Identifier {
+  return +{
     type => DQ_IDENTIFIER,
-    elements => [ @_ ]
+    elements => [ @_ ],
+  };
+}
+
+foreach my $name (values %Data::Query::Constants::CONST) {
+  no strict 'refs';
+  my $sub = "is_${name}";
+  *$sub = sub {
+    my $dq = $_[0]||$_;
+    $dq->{type} and $dq->{type} eq $name
+  };
+  push @EXPORT, $sub;
+  if (my @map = @{$map{$name}||[]}) {
+    *$name = sub {
+      my $dq = { type => $name };
+      foreach (0..$#map) {
+        $dq->{$map[$_]} = $_[$_] if defined $_[$_];
+      }
+
+      if (my $optional = $_[$#map+1]) {
+        unless(ref $optional eq 'HASH') {
+          require Carp;
+          Carp::croak("Not a hashreference");
+        }
+        @{$dq}{keys %$optional} = values %$optional;
+      }
+
+      return $dq;
+    };
+    push @EXPORT, $name;
+  }
+}
+
+sub is_Having { is_Where($_[0]) and is_Group($_[0]->{from}) }
+
+push @EXPORT, 'is_Having';
+
+sub compose (&@) {
+  my $code = shift;
+  require Scalar::Util;
+  my $type = Scalar::Util::reftype($code);
+  unless($type and $type eq 'CODE') {
+    require Carp;
+    Carp::croak("Not a subroutine reference");
+  }
+  no strict 'refs';
+
+  return shift unless @_ > 1;
+
+  use vars qw($a $b);
+
+  my $caller = caller;
+  local(*{$caller."::a"}) = \my $a;
+  local(*{$caller."::b"}) = \my $b;
+
+  $a = pop;
+  foreach (reverse @_) {
+    $b = $_;
+    $a = &{$code}();
+  }
+
+  $a;
+}
+
+sub scan_dq_nodes {
+  my ($cb_map, @queue) = @_;
+  while (my $node = shift @queue) {
+    if ($node->{type} and my $cb = $cb_map->{$node->{type}}) {
+      $cb->($node);
+    }
+    push @queue,
+      grep ref($_) eq 'HASH',
+        map +(ref($_) eq 'ARRAY' ? @$_ : $_),
+          @{$node}{grep !/\./, keys %$node};
   }
 }