lib/Data/Query/Renderer/Perl.pm

   1 package Data::Query::Renderer::Perl;
   2
   3 sub intersperse { my $i = shift; my @i = map +($_, $i), @_; pop @i; @i }
   4
   5 use Data::Query::Constants qw(DQ_IDENTIFIER);
   6 use Moo;
   7
   8 has simple_ops => (
   9   is => 'ro', builder => '_build_simple_ops'
  10 );
  11
  12 sub _build_simple_ops {
  13   +{
  14     (map +($_ => 'binop'), qw(== > < >= <= != eq ne gt lt ge le and or)),
  15     (map +($_ => 'funop'), qw(not ! defined)),
  16     (apply => 'apply'),
  17   }
  18 }
  19
  20 sub render {
  21   my $self = shift;
  22   $self->_flatten_structure($self->_render(@_))
  23 }
  24
  25 sub _flatten_structure {
  26   my ($self, $struct) = @_;
  27   my @bind;
  28   [ do {
  29       my @p = map {
  30         my $r = ref;
  31         if (!$r) { $_ }
  32         elsif ($r eq 'ARRAY') {
  33           my ($sql, @b) = @{$self->_flatten_structure($_)};
  34           push @bind, @b;
  35           $sql;
  36         }
  37         elsif ($r eq 'HASH') { push @bind, $_; () }
  38         else { die "_flatten_structure can't handle ref type $r for $_" }
  39       } @$struct;
  40       join '', map {
  41         ($p[$_], (($p[$_+1]||',') eq ',') ? () : (' '))
  42       } 0 .. $#p;
  43     },
  44     @bind
  45   ];
  46 }
  47
  48 sub _render {
  49   $_[0]->${\"_render_${\(lc($_[1]->{type})||'broken')}"}($_[1]);
  50 }
  51
  52 sub _render_broken {
  53   my ($self, $dq) = @_;
  54   require Data::Dumper::Concise;
  55   die "Broken DQ entry: ".Data::Dumper::Concise::Dumper($dq);
  56 }
  57
  58 sub _render_identifier {
  59   my ($self, $dq) = @_;
  60   return [
  61     join '->', '$_', @{$dq->{elements}}
  62   ];
  63 }
  64
  65 sub _render_value {
  66   [ '+shift', $_[1] ]
  67 }
  68
  69 sub _operator_type { 'Perl' }
  70
  71 sub _render_operator {
  72   my ($self, $dq) = @_;
  73   my $op = $dq->{operator};
  74   unless (exists $op->{$self->_operator_type}) {
  75     $op->{$self->_operator_type} = $self->_convert_op($dq);
  76   }
  77   my $op_name = $op->{$self->_operator_type};
  78   if (my $op_type = $self->{simple_ops}{$op_name}) {
  79     return $self->${\"_handle_op_type_${op_type}"}($op_name, $dq);
  80   } else {
  81     die "Unsure how to handle ${op_name}";
  82   }
  83 }
  84
  85 sub _convert_op { die "No op conversion to perl yet" }
  86
  87 sub _handle_op_type_binop {
  88   my ($self, $op_name, $dq) = @_;
  89   die "${op_name} registered as binary op but args contain "
  90       .scalar(@{$dq->{args}})." entries"
  91     unless @{$dq->{args}} == 2;
  92   [
  93     '(',
  94     $self->_render($dq->{args}[0]),
  95     $op_name,
  96     $self->_render($dq->{args}[1]),
  97     ')',
  98   ]
  99 }
 100
 101 sub _handle_op_type_funop {
 102   my ($self, $op_name, $dq) = @_;
 103   $self->_handle_funcall($op_name, $dq->{args});
 104 }
 105
 106 sub _handle_op_type_apply {
 107   my ($self, $op_name, $dq) = @_;
 108   my ($func, @args) = @{$dq->{args}};
 109   die "Function name must be identifier"
 110     unless $func->{type} eq DQ_IDENTIFIER;
 111   if (@{$func->{elements}} > 1) {
 112     die "Not decided how to handle multi-part function identifiers yet";
 113   }
 114   $self->_handle_funcall($func->{elements}[0], \@args);
 115 }
 116
 117 sub _handle_funcall {
 118   my ($self, $fun, $args) = @_;
 119   [
 120     "${fun}(",
 121     intersperse(',', map $self->_render($_), @$args),
 122     ")",
 123   ]
 124 }
 125
 126 1;