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