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