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 (my @map = @{$map{$name}||[]}) {
  79     *$name = sub {
  80       my $dq = { type => $name };
  81       foreach (0..$#map) {
  82         $dq->{$map[$_]} = $_[$_] if defined $_[$_];
  83       }
  84
  85       if (my $optional = $_[$#map+1]) {
  86         unless(ref $optional eq 'HASH') {
  87           require Carp;
  88           Carp::croak("Not a hashreference");
  89         }
  90         @{$dq}{keys %$optional} = values %$optional;
  91       }
  92
  93       return $dq;
  94     };
  95     push @EXPORT, $name;
  96   }
  97 }
  98
  99 sub is_Having { is_Where($_[0]) and is_Group($_[0]->{from}) }
 100
 101 push @EXPORT, 'is_Having';
 102
 103 sub compose (&@) {
 104   my $code = shift;
 105   require Scalar::Util;
 106   my $type = Scalar::Util::reftype($code);
 107   unless($type and $type eq 'CODE') {
 108     require Carp;
 109     Carp::croak("Not a subroutine reference");
 110   }
 111   no strict 'refs';
 112
 113   return shift unless @_ > 1;
 114
 115   use vars qw($a $b);
 116
 117   my $caller = caller;
 118   local(*{$caller."::a"}) = \my $a;
 119   local(*{$caller."::b"}) = \my $b;
 120
 121   $a = pop;
 122   foreach (reverse @_) {
 123     $b = $_;
 124     $a = &{$code}();
 125   }
 126
 127   $a;
 128 }
 129
 130
 131 1;