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