Commit | Line | Data |
515523bc |
1 | package Data::Query::Renderer::SQL::Naive; |
2 | |
3 | use strictures 1; |
4 | use SQL::ReservedWords; |
5 | use Data::Query::Constants qw(DQ_IDENTIFIER DQ_OPERATOR DQ_VALUE); |
6 | |
7 | sub new { |
8 | bless({ %{$_[1]||{}} }, (ref($_[0])||$_[0]))->BUILDALL; |
9 | } |
10 | |
11 | sub BUILDALL { |
12 | my $self = shift; |
13 | $self->{reserved_ident_parts} |
14 | ||= ( |
15 | our $_DEFAULT_RESERVED ||= { map +($_ => 1), SQL::ReservedWords->words } |
16 | ); |
17 | $self->{quote_chars}||=['']; |
18 | $self->{simple_ops}||=$self->_default_simple_ops; |
19 | return $self; |
20 | } |
21 | |
22 | sub _default_simple_ops { |
23 | +{ |
24 | (map +($_ => 'binop'), qw(= > < >= <=) ), |
25 | (map +($_ => 'unop'), (qw(NOT)) ), |
26 | (map +($_ => 'flatten'), qw(AND OR) ), |
27 | } |
28 | } |
29 | |
30 | sub render { |
31 | my $self = shift; |
32 | $self->_flatten_structure($self->_render(@_)) |
33 | } |
34 | |
35 | sub _flatten_structure { |
36 | my ($self, $struct) = @_; |
37 | my @bind; |
38 | [ (join ' ', map { |
39 | my $r = ref; |
40 | if (!$r) { $_ } |
41 | elsif ($r eq 'ARRAY') { |
42 | my ($sql, @b) = @{$self->_flatten_structure($_)}; |
43 | push @bind, @b; |
44 | $sql; |
45 | } |
46 | elsif ($r eq 'HASH') { push @bind, $_; () } |
47 | else { die "_flatten_structure can't handle ref type $r for $_" } |
48 | } @$struct), @bind ]; |
49 | } |
50 | |
51 | sub _render { |
52 | $_[0]->${\"_render_${\lc($_[1]->{type})}"}($_[1]); |
53 | } |
54 | |
55 | sub _render_identifier { |
56 | die "Unidentified identifier (SQL can no has \$_)" |
57 | unless my @i = @{$_[1]->{elements}}; |
58 | # handle single or paired quote chars |
59 | my ($q1, $q2) = @{$_[0]->{quote_chars}}[0,-1]; |
60 | my $always_quote = $_[0]->{always_quote}; |
61 | my $res_check = $_[0]->{reserved_ident_parts}; |
62 | return [ |
63 | join |
64 | $_[0]->{identifier_sep}||'.', |
65 | map +( |
66 | $_ eq '*' # Yes, this means you can't have a column just called '*'. |
67 | ? $_ # Yes, this is a feature. Go shoot the DBA if he disagrees. |
68 | : ( # reserved are stored uc, quote if non-word |
69 | $always_quote || $res_check->{+uc} || /\W/ |
70 | ? $q1.$_.$q2 |
71 | : $_ |
72 | ) |
73 | ), @i |
74 | ]; |
75 | } |
76 | |
77 | sub _render_value { |
78 | [ '?', $_[1] ]; |
79 | } |
80 | |
12e6eab8 |
81 | sub _operator_type { 'SQL.Naive' } |
82 | |
515523bc |
83 | sub _render_operator { |
84 | my ($self, $dq) = @_; |
85 | my $op = $dq->{operator}; |
12e6eab8 |
86 | unless (exists $op->{$self->_operator_type}) { |
87 | $op->{$self->_operator_type} = $self->_convert_op($dq); |
515523bc |
88 | } |
12e6eab8 |
89 | if (my $op_type = $self->{simple_ops}{my $op_name = $op->{$self->_operator_type}}) { |
515523bc |
90 | return $self->${\"_handle_op_type_${op_type}"}($op_name, $dq); |
91 | } |
12e6eab8 |
92 | die "Couldn't render operator ".$op->{$self->_operator_type}; |
515523bc |
93 | } |
94 | |
95 | sub _handle_op_type_binop { |
96 | my ($self, $op_name, $dq) = @_; |
97 | die "${op_name} registered as binary op but args contain " |
98 | .scalar(@{$dq->{args}})." entries" |
99 | unless @{$dq->{args}} == 2; |
100 | [ |
101 | $self->_render($dq->{args}[0]), |
102 | $op_name, |
103 | $self->_render($dq->{args}[1]), |
104 | ] |
105 | } |
106 | |
107 | sub _handle_op_type_unop { |
108 | my ($self, $op_name, $dq) = @_; |
109 | die "${op_name} registered as unary op but args contain " |
110 | .scalar(@{$dq->{args}})." entries" |
111 | unless @{$dq->{args}} == 1; |
112 | [ |
113 | [ $op_name ], |
114 | $self->_render($dq->{args}[0]), |
115 | ] |
116 | } |
117 | |
118 | sub _handle_op_type_flatten { |
119 | my ($self, $op_name, $dq) = @_; |
120 | my @argq = @{$dq->{args}}; |
121 | my @arg_final; |
122 | while (my $arg = shift @argq) { |
123 | |
124 | unless ($arg->{type} eq DQ_OPERATOR) { |
125 | push @arg_final, $arg; |
126 | next; |
127 | } |
128 | |
129 | my $op = $arg->{operator}; |
12e6eab8 |
130 | unless (exists $op->{$self->_operator_type}) { |
131 | $op->{$self->_operator_type} = $self->_convert_op($arg); |
515523bc |
132 | } |
133 | |
12e6eab8 |
134 | if ($op->{$self->_operator_type} eq $op_name) { |
515523bc |
135 | unshift @argq, @{$arg->{args}}; |
136 | } else { |
137 | push @arg_final, $arg; |
138 | } |
139 | } |
140 | my @sql = ('(', map +($self->_render($_), $op_name), @arg_final); |
141 | $sql[-1] = ')'; # replace final AND or whatever with ) |
142 | \@sql; |
143 | } |
144 | |
145 | sub _convert_op { |
146 | my ($self, $dq) = @_; |
147 | if (my $perl_op = $dq->{'operator'}->{'Perl'}) { |
148 | for ($perl_op) { |
149 | $_ eq '==' and return '='; |
150 | $_ eq 'eq' and return '='; |
151 | $_ eq '!' and return 'NOT'; |
152 | } |
153 | return uc $perl_op; # hope! |
154 | } |
155 | die "Can't convert non-perl op yet"; |
156 | } |
157 | |
158 | 1; |