fixups for HAVING clauses

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

diff --git a/lib/Data/Query/ExprHelpers.pm b/lib/Data/Query/ExprHelpers.pm
index 6b2cbef..6020be6 100644 (file)
--- a/lib/Data/Query/ExprHelpers.pm
+++ b/lib/Data/Query/ExprHelpers.pm
@@ -5,7 +5,7 @@ use Data::Query::Constants;
 
 use base qw(Exporter);
 
-our @EXPORT = qw(perl_scalar_value perl_operator Literal Identifier);
+our @EXPORT = qw(perl_scalar_value perl_operator Literal Identifier compose);
 
 sub perl_scalar_value {
   +{
@@ -40,14 +40,17 @@ my %map = (
 );
 
 sub Literal {
+  my $subtype = shift;
   if (ref($_[0])) {
     return +{
       type => DQ_LITERAL,
-      parts => @{$_[0]},
+      subtype => $subtype,
+      parts => $_[0],
     };
   }
   return +{
     type => DQ_LITERAL,
+    subtype => $subtype,
     literal => $_[0],
     ($_[1] ? (values => $_[1]) : ())
   };
@@ -65,7 +68,7 @@ foreach my $name (values %Data::Query::Constants::CONST) {
   my $sub = "is_${name}";
   *$sub = sub {
     my $dq = $_[0]||$_;
-    $dq->{type} eq $name
+    $dq->{type} and $dq->{type} eq $name
   };
   push @EXPORT, $sub;
   if ($map{$name}) {
@@ -81,4 +84,36 @@ foreach my $name (values %Data::Query::Constants::CONST) {
   }
 }
 
+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;
+}
+
+
 1;