lib/Data/Query/ExprHelpers.pm

   1 package Data::Query::ExprHelpers;
   2
   3 use strictures 1;
   4 use Data::Query::Constants;
   5
   6 use base qw(Exporter);
   7
   8 our @EXPORT = qw(
   9   perl_scalar_value perl_operator Literal Identifier compose intersperse
  10 );
  11
  12 sub intersperse { my $i = shift; my @i = map +($_, $i), @_; pop @i; @i }
  13
  14 sub perl_scalar_value {
  15   +{
  16     type => DQ_VALUE,
  17     subtype => { Perl => 'Scalar' },
  18     value => $_[0],
  19     $_[1] ? (value_meta => $_[1]) : ()
  20   }
  21 }
  22
  23 sub perl_operator {
  24   my ($op, @args) = @_;
  25   +{
  26     type => DQ_OPERATOR,
  27     operator => { Perl => $op },
  28     args => \@args
  29   }
  30 }
  31
  32 my %map = (
  33   Join => [ qw(left right on outer) ],
  34   Alias => [ qw(to from) ],
  35   Operator => [ qw(operator args) ],
  36   Select => [ qw(select from) ],
  37   Where => [ qw(where from) ],
  38   Order => [ qw(by reverse nulls from) ],
  39   Group => [ qw(by from) ],
  40   Delete => [ qw(where target) ],
  41   Update => [ qw(set where target) ],
  42   Insert => [ qw(names values target returning) ],
  43   Slice => [ qw(offset limit from) ],
  44 );
  45
  46 sub Literal {
  47   my $subtype = shift;
  48   if (ref($_[0])) {
  49     return +{
  50       type => DQ_LITERAL,
  51       subtype => $subtype,
  52       parts => $_[0],
  53     };
  54   }
  55   return +{
  56     type => DQ_LITERAL,
  57     subtype => $subtype,
  58     literal => $_[0],
  59     ($_[1] ? (values => $_[1]) : ())
  60   };
  61 }
  62
  63 sub Identifier {
  64   return +{
  65     type => DQ_IDENTIFIER,
  66     elements => [ @_ ],
  67   };
  68 }
  69
  70 foreach my $name (values %Data::Query::Constants::CONST) {
  71   no strict 'refs';
  72   my $sub = "is_${name}";
  73   *$sub = sub {
  74     my $dq = $_[0]||$_;
  75     $dq->{type} and $dq->{type} eq $name
  76   };
  77   push @EXPORT, $sub;
  78   if ($map{$name}) {
  79     my @map = @{$map{$name}};
  80     *$name = sub {
  81       my $dq = { type => $name };
  82       foreach (0..$#_) {
  83         $dq->{$map[$_]} = $_[$_] if defined $_[$_];
  84       }
  85       return $dq;
  86     };
  87     push @EXPORT, $name;
  88   }
  89 }
  90
  91 sub is_Having { is_Where($_[0]) and is_Group($_[0]->{from}) }
  92
  93 push @EXPORT, 'is_Having';
  94
  95 sub compose (&@) {
  96   my $code = shift;
  97   require Scalar::Util;
  98   my $type = Scalar::Util::reftype($code);
  99   unless($type and $type eq 'CODE') {
 100     require Carp;
 101     Carp::croak("Not a subroutine reference");
 102   }
 103   no strict 'refs';
 104
 105   return shift unless @_ > 1;
 106
 107   use vars qw($a $b);
 108
 109   my $caller = caller;
 110   local(*{$caller."::a"}) = \my $a;
 111   local(*{$caller."::b"}) = \my $b;
 112
 113   $a = pop;
 114   foreach (reverse @_) {
 115     $b = $_;
 116     $a = &{$code}();
 117   }
 118
 119   $a;
 120 }
 121
 122
 123 1;