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 | |
9c8fc055 |
51 | # I present this to permit strange people to easily supply a patch to lc() |
52 | # their keywords, as I have heard many desire to do, lest they infect me |
53 | # with whatever malady caused this desire by their continued proximity for |
54 | # want of such a feature. |
55 | |
56 | sub _format_keyword { $_[1] } |
57 | |
515523bc |
58 | sub _render { |
59 | $_[0]->${\"_render_${\lc($_[1]->{type})}"}($_[1]); |
60 | } |
61 | |
62 | sub _render_identifier { |
63 | die "Unidentified identifier (SQL can no has \$_)" |
64 | unless my @i = @{$_[1]->{elements}}; |
65 | # handle single or paired quote chars |
66 | my ($q1, $q2) = @{$_[0]->{quote_chars}}[0,-1]; |
67 | my $always_quote = $_[0]->{always_quote}; |
68 | my $res_check = $_[0]->{reserved_ident_parts}; |
69 | return [ |
70 | join |
71 | $_[0]->{identifier_sep}||'.', |
72 | map +( |
73 | $_ eq '*' # Yes, this means you can't have a column just called '*'. |
74 | ? $_ # Yes, this is a feature. Go shoot the DBA if he disagrees. |
75 | : ( # reserved are stored uc, quote if non-word |
76 | $always_quote || $res_check->{+uc} || /\W/ |
77 | ? $q1.$_.$q2 |
78 | : $_ |
79 | ) |
80 | ), @i |
81 | ]; |
82 | } |
83 | |
84 | sub _render_value { |
85 | [ '?', $_[1] ]; |
86 | } |
87 | |
12e6eab8 |
88 | sub _operator_type { 'SQL.Naive' } |
89 | |
515523bc |
90 | sub _render_operator { |
91 | my ($self, $dq) = @_; |
92 | my $op = $dq->{operator}; |
12e6eab8 |
93 | unless (exists $op->{$self->_operator_type}) { |
94 | $op->{$self->_operator_type} = $self->_convert_op($dq); |
515523bc |
95 | } |
12e6eab8 |
96 | if (my $op_type = $self->{simple_ops}{my $op_name = $op->{$self->_operator_type}}) { |
515523bc |
97 | return $self->${\"_handle_op_type_${op_type}"}($op_name, $dq); |
98 | } |
12e6eab8 |
99 | die "Couldn't render operator ".$op->{$self->_operator_type}; |
515523bc |
100 | } |
101 | |
102 | sub _handle_op_type_binop { |
103 | my ($self, $op_name, $dq) = @_; |
104 | die "${op_name} registered as binary op but args contain " |
105 | .scalar(@{$dq->{args}})." entries" |
106 | unless @{$dq->{args}} == 2; |
107 | [ |
108 | $self->_render($dq->{args}[0]), |
109 | $op_name, |
110 | $self->_render($dq->{args}[1]), |
111 | ] |
112 | } |
113 | |
114 | sub _handle_op_type_unop { |
115 | my ($self, $op_name, $dq) = @_; |
116 | die "${op_name} registered as unary op but args contain " |
117 | .scalar(@{$dq->{args}})." entries" |
118 | unless @{$dq->{args}} == 1; |
119 | [ |
120 | [ $op_name ], |
121 | $self->_render($dq->{args}[0]), |
122 | ] |
123 | } |
124 | |
125 | sub _handle_op_type_flatten { |
126 | my ($self, $op_name, $dq) = @_; |
127 | my @argq = @{$dq->{args}}; |
128 | my @arg_final; |
129 | while (my $arg = shift @argq) { |
130 | |
131 | unless ($arg->{type} eq DQ_OPERATOR) { |
132 | push @arg_final, $arg; |
133 | next; |
134 | } |
135 | |
136 | my $op = $arg->{operator}; |
12e6eab8 |
137 | unless (exists $op->{$self->_operator_type}) { |
138 | $op->{$self->_operator_type} = $self->_convert_op($arg); |
515523bc |
139 | } |
140 | |
12e6eab8 |
141 | if ($op->{$self->_operator_type} eq $op_name) { |
515523bc |
142 | unshift @argq, @{$arg->{args}}; |
143 | } else { |
144 | push @arg_final, $arg; |
145 | } |
146 | } |
147 | my @sql = ('(', map +($self->_render($_), $op_name), @arg_final); |
148 | $sql[-1] = ')'; # replace final AND or whatever with ) |
149 | \@sql; |
150 | } |
151 | |
152 | sub _convert_op { |
153 | my ($self, $dq) = @_; |
154 | if (my $perl_op = $dq->{'operator'}->{'Perl'}) { |
155 | for ($perl_op) { |
156 | $_ eq '==' and return '='; |
157 | $_ eq 'eq' and return '='; |
158 | $_ eq '!' and return 'NOT'; |
159 | } |
160 | return uc $perl_op; # hope! |
161 | } |
162 | die "Can't convert non-perl op yet"; |
163 | } |
9c8fc055 |
164 | |
165 | sub _render_select { |
166 | my ($self, $dq) = @_; |
167 | die "Empty select list" unless @{$dq->{select}}; |
168 | |
169 | # it is, in fact, completely valid for there to be nothing for us |
170 | # to project from since many databases handle 'SELECT 1;' fine |
171 | |
172 | my @select = map { |
173 | # we should perhaps validate that what we've been handed |
174 | # is an expression and possibly an identifier - at least a |
175 | # debugging mode that does such is almost certainly worthwhile; |
176 | # but for present I'm focusing on making this work. |
177 | my $e = $self->_render($_->{expr}); |
178 | $_->{name} ? [ $e, 'AS', $self->_render($_->{name}), ',' ] : [ $e, ',' ] |
179 | } @{$dq->{select}}; |
180 | |
181 | # we put the commas inside the [] for each entry as a hint to the pretty |
182 | # printer downstreamso now we need to eliminate the comma from the last |
183 | # entry - we know there always is one due to the die guard at the top |
184 | |
185 | pop @{$select[-1]}; |
186 | |
187 | return [ |
188 | $self->_format_keyword('SELECT'), |
189 | \@select, |
190 | # if present this may be a bare FROM, a FROM+WHERE, or a FROM+WHERE+GROUP |
191 | # since we're the SELECT and therefore always come first, we don't care. |
2cf0bb42 |
192 | ($dq->{from} |
193 | ? ($self->_format_keyword('FROM'), @{$self->_render($dq->{from})}) |
194 | : () |
195 | ) |
196 | ]; |
197 | } |
198 | |
199 | sub _render_alias { |
200 | my ($self, $dq) = @_; |
201 | # FROM foo foo -> FROM foo |
202 | # FROM foo.bar bar -> FROM foo.bar |
203 | if ($dq->{alias}{type} eq DQ_IDENTIFIER) { |
204 | if ($dq->{alias}{elements}[-1] eq $dq->{as}) { |
205 | return $self->_render($dq->{alias}); |
206 | } |
207 | } |
208 | return [ |
209 | $self->_render($dq->{alias}), |
210 | ' ', |
211 | $self->_render_identifier({ elements => [ $dq->{as} ] }) |
212 | ]; |
213 | } |
214 | |
215 | sub _render_literal { |
216 | my ($self, $dq) = @_; |
217 | unless ($dq->{subtype} eq 'SQL') { |
218 | die "Can't render non-SQL literal"; |
219 | } |
220 | return [ |
221 | $dq->{literal}, |
9c8fc055 |
222 | ]; |
223 | } |
224 | |
515523bc |
225 | 1; |