Commit | Line | Data |
81648036 |
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; |