Commit | Line | Data |
a82e41dc |
1 | package SQL::Abstract::Converter; |
2 | |
3 | use Carp (); |
4 | use List::Util (); |
5 | use Scalar::Util (); |
4caa4620 |
6 | use Data::Query::ExprHelpers; |
9ea5bb0f |
7 | use Sub::Quote 'quote_sub'; |
a82e41dc |
8 | use Moo; |
8b9b83ae |
9 | use namespace::clean; |
a82e41dc |
10 | |
11 | has renderer_will_quote => ( |
12 | is => 'ro' |
13 | ); |
14 | |
15 | has lower_case => ( |
4caa4620 |
16 | is => 'ro' |
a82e41dc |
17 | ); |
18 | |
19 | has default_logic => ( |
9ea5bb0f |
20 | is => 'ro', coerce => quote_sub( 'uc($_[0])' ), default => 'OR' |
a82e41dc |
21 | ); |
22 | |
23 | has bind_meta => ( |
9ea5bb0f |
24 | is => 'ro', default => 1 |
a82e41dc |
25 | ); |
26 | |
9ea5bb0f |
27 | has cmp => (is => 'ro', default => '=' ); |
a82e41dc |
28 | |
9ea5bb0f |
29 | has sqltrue => (is => 'ro', default => '1=1' ); |
30 | has sqlfalse => (is => 'ro', default => '0=1' ); |
a82e41dc |
31 | |
9ea5bb0f |
32 | has special_ops => (is => 'ro', default => quote_sub( '[]' ) ); |
a82e41dc |
33 | |
34 | # XXX documented but I don't current fail any tests not using it |
9ea5bb0f |
35 | has unary_ops => (is => 'ro', default => quote_sub( '[]' ) ); |
a82e41dc |
36 | |
37 | has injection_guard => ( |
38 | is => 'ro', |
9ea5bb0f |
39 | default => quote_sub( q{ |
a82e41dc |
40 | qr/ |
41 | \; |
42 | | |
43 | ^ \s* go \s |
44 | /xmi; |
9ea5bb0f |
45 | } ), |
a82e41dc |
46 | ); |
47 | |
48 | has identifier_sep => ( |
9ea5bb0f |
49 | is => 'ro', default => '.', |
a82e41dc |
50 | ); |
51 | |
9ea5bb0f |
52 | has always_quote => (is => 'ro', default => 1); |
a82e41dc |
53 | |
54 | has convert => (is => 'ro'); |
55 | |
56 | has array_datatypes => (is => 'ro'); |
57 | |
2e50f418 |
58 | has equality_op => ( |
59 | is => 'ro', |
9ea5bb0f |
60 | default => quote_sub( q{ qr/^ (?: = ) $/ix } ), |
2e50f418 |
61 | ); |
62 | |
63 | has inequality_op => ( |
64 | is => 'ro', |
9ea5bb0f |
65 | default => quote_sub( q{ qr/^ (?: != | <> ) $/ix } ), |
2e50f418 |
66 | ); |
67 | |
68 | has like_op => ( |
69 | is => 'ro', |
9ea5bb0f |
70 | default => quote_sub( q{ qr/^ (?: is \s+ )? r?like $/xi } ), |
2e50f418 |
71 | ); |
72 | |
73 | has not_like_op => ( |
74 | is => 'ro', |
9ea5bb0f |
75 | default => quote_sub( q{ qr/^ (?: is \s+ )? not \s+ r?like $/xi } ), |
2e50f418 |
76 | ); |
77 | |
78 | |
a82e41dc |
79 | sub _literal_to_dq { |
80 | my ($self, $literal) = @_; |
81 | my @bind; |
82 | ($literal, @bind) = @$literal if ref($literal) eq 'ARRAY'; |
3ed3c560 |
83 | Literal('SQL', $literal, [ $self->_bind_to_dq(@bind) ]); |
a82e41dc |
84 | } |
85 | |
86 | sub _bind_to_dq { |
87 | my ($self, @bind) = @_; |
88 | return unless @bind; |
89 | $self->bind_meta |
90 | ? do { |
91 | $self->_assert_bindval_matches_bindtype(@bind); |
92 | map perl_scalar_value(reverse @$_), @bind |
93 | } |
94 | : map perl_scalar_value($_), @bind |
95 | } |
96 | |
97 | sub _value_to_dq { |
98 | my ($self, $value) = @_; |
99 | $self->_maybe_convert_dq(perl_scalar_value($value, our $Cur_Col_Meta)); |
100 | } |
101 | |
102 | sub _ident_to_dq { |
103 | my ($self, $ident) = @_; |
104 | $self->_assert_pass_injection_guard($ident) |
105 | unless $self->renderer_will_quote; |
95516ac5 |
106 | $self->_maybe_convert_dq( |
107 | Identifier(do { |
108 | if (my $sep = $self->identifier_sep) { |
109 | split /\Q$sep/, $ident |
110 | } else { |
111 | $ident |
112 | } |
113 | }) |
114 | ); |
a82e41dc |
115 | } |
116 | |
117 | sub _maybe_convert_dq { |
118 | my ($self, $dq) = @_; |
119 | if (my $c = $self->{where_convert}) { |
4caa4620 |
120 | Operator({ 'SQL.Naive' => 'apply' }, [ |
f3c68822 |
121 | Identifier($self->_sqlcase($c)), |
4caa4620 |
122 | $dq |
123 | ] |
124 | ); |
a82e41dc |
125 | } else { |
126 | $dq; |
127 | } |
128 | } |
129 | |
130 | sub _op_to_dq { |
131 | my ($self, $op, @args) = @_; |
132 | $self->_assert_pass_injection_guard($op); |
4caa4620 |
133 | Operator({ 'SQL.Naive' => $op }, \@args); |
a82e41dc |
134 | } |
135 | |
136 | sub _assert_pass_injection_guard { |
137 | if ($_[1] =~ $_[0]->{injection_guard}) { |
138 | my $class = ref $_[0]; |
139 | die "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the " |
140 | . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own " |
141 | . "{injection_guard} attribute to ${class}->new()" |
142 | } |
143 | } |
144 | |
145 | sub _insert_to_dq { |
146 | my ($self, $table, $data, $options) = @_; |
147 | my (@names, @values); |
148 | if (ref($data) eq 'HASH') { |
149 | @names = sort keys %$data; |
150 | foreach my $k (@names) { |
151 | local our $Cur_Col_Meta = $k; |
152 | push @values, $self->_mutation_rhs_to_dq($data->{$k}); |
153 | } |
154 | } elsif (ref($data) eq 'ARRAY') { |
155 | local our $Cur_Col_Meta; |
156 | @values = map $self->_mutation_rhs_to_dq($_), @$data; |
157 | } else { |
158 | die "Not handled yet"; |
159 | } |
160 | my $returning; |
161 | if (my $r_source = $options->{returning}) { |
162 | $returning = [ |
163 | map +(ref($_) ? $self->_expr_to_dq($_) : $self->_ident_to_dq($_)), |
164 | (ref($r_source) eq 'ARRAY' ? @$r_source : $r_source), |
165 | ]; |
166 | } |
4caa4620 |
167 | Insert( |
168 | (@names ? ([ map $self->_ident_to_dq($_), @names ]) : undef), |
169 | [ \@values ], |
170 | $self->_table_to_dq($table), |
171 | ($returning ? ($returning) : undef), |
172 | ); |
a82e41dc |
173 | } |
174 | |
175 | sub _mutation_rhs_to_dq { |
176 | my ($self, $v) = @_; |
177 | if (ref($v) eq 'ARRAY') { |
178 | if ($self->{array_datatypes}) { |
179 | return $self->_value_to_dq($v); |
180 | } |
181 | $v = \do { my $x = $v }; |
182 | } |
183 | if (ref($v) eq 'HASH') { |
184 | my ($op, $arg, @rest) = %$v; |
185 | |
186 | die 'Operator calls in update/insert must be in the form { -op => $arg }' |
5245699d |
187 | if (@rest or not $op =~ /^\-/); |
a82e41dc |
188 | } |
189 | return $self->_expr_to_dq($v); |
190 | } |
191 | |
192 | sub _update_to_dq { |
193 | my ($self, $table, $data, $where) = @_; |
194 | |
195 | die "Unsupported data type specified to \$sql->update" |
196 | unless ref $data eq 'HASH'; |
197 | |
198 | my @set; |
199 | |
200 | foreach my $k (sort keys %$data) { |
201 | my $v = $data->{$k}; |
202 | local our $Cur_Col_Meta = $k; |
203 | push @set, [ $self->_ident_to_dq($k), $self->_mutation_rhs_to_dq($v) ]; |
204 | } |
205 | |
4caa4620 |
206 | Update( |
207 | \@set, |
208 | $self->_where_to_dq($where), |
209 | $self->_table_to_dq($table), |
210 | ); |
a82e41dc |
211 | } |
212 | |
213 | sub _source_to_dq { |
214 | my ($self, $table, undef, $where) = @_; |
215 | |
216 | my $source_dq = $self->_table_to_dq($table); |
217 | |
218 | if (my $where_dq = $self->_where_to_dq($where)) { |
4caa4620 |
219 | $source_dq = Where($where_dq, $source_dq); |
a82e41dc |
220 | } |
221 | |
222 | $source_dq; |
223 | } |
224 | |
225 | sub _select_to_dq { |
226 | my $self = shift; |
227 | my ($table, $fields, $where, $order) = @_; |
228 | |
229 | my $source_dq = $self->_source_to_dq(@_); |
230 | |
231 | my $ordered_dq = do { |
232 | if ($order) { |
36e3ea6c |
233 | $self->_order_by_to_dq($order, undef, undef, $source_dq); |
a82e41dc |
234 | } else { |
235 | $source_dq |
236 | } |
237 | }; |
238 | |
87af4204 |
239 | return $self->_select_select_to_dq($fields, $ordered_dq); |
a82e41dc |
240 | } |
241 | |
87af4204 |
242 | sub _select_select_to_dq { |
a82e41dc |
243 | my ($self, $fields, $from_dq) = @_; |
244 | |
245 | $fields ||= '*'; |
246 | |
4caa4620 |
247 | Select( |
248 | $self->_select_field_list_to_dq($fields), |
249 | $from_dq, |
250 | ); |
a82e41dc |
251 | } |
252 | |
253 | sub _select_field_list_to_dq { |
254 | my ($self, $fields) = @_; |
87af4204 |
255 | [ map $self->_select_field_to_dq($_), |
256 | ref($fields) eq 'ARRAY' ? @$fields : $fields ]; |
a82e41dc |
257 | } |
258 | |
259 | sub _select_field_to_dq { |
260 | my ($self, $field) = @_; |
87af4204 |
261 | if (my $ref = ref($field)) { |
262 | if ($ref eq 'REF' and ref($$field) eq 'HASH') { |
263 | return $$field; |
264 | } else { |
265 | return $self->_literal_to_dq($$field); |
266 | } |
267 | } |
268 | return $self->_ident_to_dq($field) |
a82e41dc |
269 | } |
270 | |
271 | sub _delete_to_dq { |
272 | my ($self, $table, $where) = @_; |
4caa4620 |
273 | Delete( |
274 | $self->_where_to_dq($where), |
275 | $self->_table_to_dq($table), |
276 | ); |
a82e41dc |
277 | } |
278 | |
279 | sub _where_to_dq { |
280 | my ($self, $where, $logic) = @_; |
281 | |
282 | return undef unless defined($where); |
283 | |
e177c256 |
284 | # if we're given a simple string assume it's a literal |
285 | return $self->_literal_to_dq($where) if !ref($where); |
286 | |
a82e41dc |
287 | # turn the convert misfeature on - only used in WHERE clauses |
288 | local $self->{where_convert} = $self->convert; |
289 | |
290 | return $self->_expr_to_dq($where, $logic); |
291 | } |
292 | |
6da91977 |
293 | my %op_conversions = ( |
294 | '==' => '=', |
295 | 'eq' => '=', |
296 | 'ne' => '!=', |
297 | '!' => 'NOT', |
298 | 'gt' => '>', |
299 | 'ge' => '>=', |
300 | 'lt' => '<', |
301 | 'le' => '<=', |
302 | 'defined' => 'IS NOT NULL', |
303 | ); |
304 | |
a82e41dc |
305 | sub _expr_to_dq { |
306 | my ($self, $where, $logic) = @_; |
307 | |
308 | if (ref($where) eq 'ARRAY') { |
309 | return $self->_expr_to_dq_ARRAYREF($where, $logic); |
310 | } elsif (ref($where) eq 'HASH') { |
311 | return $self->_expr_to_dq_HASHREF($where, $logic); |
312 | } elsif ( |
313 | ref($where) eq 'SCALAR' |
314 | or (ref($where) eq 'REF' and ref($$where) eq 'ARRAY') |
315 | ) { |
316 | return $self->_literal_to_dq($$where); |
62d17764 |
317 | } elsif (ref($where) eq 'REF' and ref($$where) eq 'HASH') { |
6da91977 |
318 | return map_dq_tree { |
319 | if ( |
320 | is_Operator |
321 | and not $_->{operator}{'SQL.Naive'} |
322 | and my $op = $_->{operator}{'Perl'} |
323 | ) { |
324 | my $sql_op = $op_conversions{$op} || uc($op); |
325 | return +{ |
326 | %{$_}, |
327 | operator => { 'SQL.Naive' => $sql_op } |
328 | }; |
329 | } |
330 | return $_; |
331 | } $$where; |
a82e41dc |
332 | } elsif (!ref($where) or Scalar::Util::blessed($where)) { |
333 | return $self->_value_to_dq($where); |
334 | } |
335 | die "Can't handle $where"; |
336 | } |
337 | |
338 | sub _expr_to_dq_ARRAYREF { |
339 | my ($self, $where, $logic) = @_; |
340 | |
341 | $logic = uc($logic || $self->default_logic || 'OR'); |
342 | $logic eq 'AND' or $logic eq 'OR' or die "unknown logic: $logic"; |
343 | |
344 | return unless @$where; |
345 | |
346 | my ($first, @rest) = @$where; |
347 | |
348 | return $self->_expr_to_dq($first) unless @rest; |
349 | |
350 | my $first_dq = do { |
351 | if (!ref($first)) { |
352 | $self->_where_hashpair_to_dq($first => shift(@rest)); |
353 | } else { |
354 | $self->_expr_to_dq($first); |
355 | } |
356 | }; |
357 | |
358 | return $self->_expr_to_dq_ARRAYREF(\@rest, $logic) unless $first_dq; |
359 | |
360 | $self->_op_to_dq( |
361 | $logic, $first_dq, $self->_expr_to_dq_ARRAYREF(\@rest, $logic) |
362 | ); |
363 | } |
364 | |
365 | sub _expr_to_dq_HASHREF { |
366 | my ($self, $where, $logic) = @_; |
367 | |
368 | $logic = uc($logic) if $logic; |
369 | |
370 | my @dq = map { |
371 | $self->_where_hashpair_to_dq($_ => $where->{$_}, $logic) |
372 | } sort keys %$where; |
373 | |
374 | return $dq[0] unless @dq > 1; |
375 | |
376 | my $final = pop(@dq); |
377 | |
378 | foreach my $dq (reverse @dq) { |
379 | $final = $self->_op_to_dq($logic||'AND', $dq, $final); |
380 | } |
381 | |
382 | return $final; |
383 | } |
384 | |
385 | sub _where_to_dq_SCALAR { |
386 | shift->_value_to_dq(@_); |
387 | } |
388 | |
389 | sub _apply_to_dq { |
390 | my ($self, $op, $v) = @_; |
391 | my @args = map $self->_expr_to_dq($_), (ref($v) eq 'ARRAY' ? @$v : $v); |
392 | |
393 | # Ok. Welcome to stupid compat code land. An SQLA expr that would in the |
394 | # absence of this piece of crazy render to: |
395 | # |
396 | # A( B( C( x ) ) ) |
397 | # |
398 | # such as |
399 | # |
400 | # { -a => { -b => { -c => $x } } } |
401 | # |
402 | # actually needs to render to: |
403 | # |
404 | # A( B( C x ) ) |
405 | # |
406 | # because SQL sucks, and databases are hateful, and SQLA is Just That DWIM. |
407 | # |
408 | # However, we don't want to catch 'A(x)' and turn it into 'A x' |
409 | # |
410 | # So the way we deal with this is to go through all our arguments, and |
411 | # then if the argument is -also- an apply, i.e. at least 'B', we check |
412 | # its arguments - and if there's only one of them, and that isn't an apply, |
413 | # then we convert to the bareword form. The end result should be: |
414 | # |
415 | # A( x ) -> A( x ) |
416 | # A( B( x ) ) -> A( B x ) |
417 | # A( B( C( x ) ) ) -> A( B( C x ) ) |
418 | # A( B( x + y ) ) -> A( B( x + y ) ) |
419 | # A( B( x, y ) ) -> A( B( x, y ) ) |
420 | # |
421 | # If this turns out not to be quite right, please add additional tests |
422 | # to either 01generate.t or 02where.t *and* update this comment. |
423 | |
424 | foreach my $arg (@args) { |
425 | if ( |
f3c68822 |
426 | is_Operator($arg) and $arg->{operator}{'SQL.Naive'} eq 'apply' |
427 | and @{$arg->{args}} == 2 and !is_Operator($arg->{args}[1]) |
428 | |
a82e41dc |
429 | ) { |
430 | $arg->{operator}{'SQL.Naive'} = (shift @{$arg->{args}})->{elements}->[0]; |
431 | } |
432 | } |
433 | $self->_assert_pass_injection_guard($op); |
434 | return $self->_op_to_dq( |
435 | apply => $self->_ident_to_dq($op), @args |
436 | ); |
437 | } |
438 | |
439 | sub _where_hashpair_to_dq { |
440 | my ($self, $k, $v, $logic) = @_; |
441 | |
442 | if ($k =~ /^-(.*)/s) { |
443 | my $op = uc($1); |
444 | if ($op eq 'AND' or $op eq 'OR') { |
445 | return $self->_expr_to_dq($v, $op); |
446 | } elsif ($op eq 'NEST') { |
447 | return $self->_expr_to_dq($v); |
448 | } elsif ($op eq 'NOT') { |
449 | return $self->_op_to_dq(NOT => $self->_expr_to_dq($v)); |
450 | } elsif ($op eq 'BOOL') { |
451 | return ref($v) ? $self->_expr_to_dq($v) : $self->_ident_to_dq($v); |
452 | } elsif ($op eq 'NOT_BOOL') { |
453 | return $self->_op_to_dq( |
454 | NOT => ref($v) ? $self->_expr_to_dq($v) : $self->_ident_to_dq($v) |
455 | ); |
456 | } elsif ($op eq 'IDENT') { |
457 | return $self->_ident_to_dq($v); |
458 | } elsif ($op eq 'VALUE') { |
459 | return $self->_value_to_dq($v); |
460 | } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+/) { |
461 | die "Use of [and|or|nest]_N modifiers is no longer supported"; |
462 | } else { |
463 | return $self->_apply_to_dq($op, $v); |
464 | } |
465 | } else { |
466 | local our $Cur_Col_Meta = $k; |
467 | if (ref($v) eq 'ARRAY') { |
468 | if (!@$v) { |
469 | return $self->_literal_to_dq($self->{sqlfalse}); |
470 | } elsif (defined($v->[0]) && $v->[0] =~ /-(and|or)/i) { |
471 | return $self->_expr_to_dq_ARRAYREF([ |
472 | map +{ $k => $_ }, @{$v}[1..$#$v] |
473 | ], uc($1)); |
474 | } |
475 | return $self->_expr_to_dq_ARRAYREF([ |
476 | map +{ $k => $_ }, @$v |
477 | ], $logic); |
478 | } elsif (ref($v) eq 'SCALAR' or (ref($v) eq 'REF' and ref($$v) eq 'ARRAY')) { |
3ed3c560 |
479 | return Literal('SQL', [ $self->_ident_to_dq($k), $self->_literal_to_dq($$v) ]); |
a82e41dc |
480 | } |
481 | my ($op, $rhs) = do { |
482 | if (ref($v) eq 'HASH') { |
483 | if (keys %$v > 1) { |
484 | return $self->_expr_to_dq_ARRAYREF([ |
485 | map +{ $k => { $_ => $v->{$_} } }, sort keys %$v |
486 | ], $logic||'AND'); |
487 | } |
488 | my ($op, $value) = %$v; |
489 | s/^-//, s/_/ /g for $op; |
5245699d |
490 | if ($op =~ /^(?:and|or)$/i) { |
a82e41dc |
491 | return $self->_expr_to_dq({ $k => $value }, $op); |
492 | } elsif ( |
493 | my $special_op = List::Util::first {$op =~ $_->{regex}} |
494 | @{$self->{special_ops}} |
495 | ) { |
496 | return $self->_literal_to_dq( |
497 | [ $special_op->{handler}->($k, $op, $value) ] |
5245699d |
498 | ); |
a82e41dc |
499 | } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+$/i) { |
500 | die "Use of [and|or|nest]_N modifiers is no longer supported"; |
501 | } |
502 | (uc($op), $value); |
503 | } else { |
504 | ($self->{cmp}, $v); |
505 | } |
506 | }; |
507 | if ($op eq 'BETWEEN' or $op eq 'IN' or $op eq 'NOT IN' or $op eq 'NOT BETWEEN') { |
cf9a9cc7 |
508 | die "Argument passed to the '$op' operator can not be undefined" unless defined $rhs; |
023fd01d |
509 | $rhs = [$rhs] unless ref $rhs; |
a82e41dc |
510 | if (ref($rhs) ne 'ARRAY') { |
5245699d |
511 | if ($op =~ /^(?:NOT )?IN$/) { |
a82e41dc |
512 | # have to add parens if none present because -in => \"SELECT ..." |
513 | # got documented. mst hates everything. |
514 | if (ref($rhs) eq 'SCALAR') { |
515 | my $x = $$rhs; |
516 | 1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s); |
517 | $rhs = \$x; |
43da3819 |
518 | } elsif (ref($rhs) eq 'REF') { |
519 | if (ref($$rhs) eq 'ARRAY') { |
520 | my ($x, @rest) = @{$$rhs}; |
521 | 1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s); |
522 | $rhs = \[ $x, @rest ]; |
523 | } elsif (ref($$rhs) eq 'HASH') { |
524 | return $self->_op_to_dq($op, $self->_ident_to_dq($k), $$rhs); |
525 | } |
a82e41dc |
526 | } |
527 | } |
528 | return $self->_op_to_dq( |
529 | $op, $self->_ident_to_dq($k), $self->_literal_to_dq($$rhs) |
530 | ); |
531 | } |
052d09f0 |
532 | die "Operator '$op' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref" |
533 | if $op =~ /^(?:NOT )?BETWEEN$/ and (@$rhs != 2 or grep !defined, @$rhs); |
5b670507 |
534 | if (grep !defined, @$rhs) { |
535 | my ($inop, $logic, $nullop) = $op =~ /^NOT/ |
536 | ? (-not_in => AND => { '!=' => undef }) |
537 | : (-in => OR => undef); |
39221d2b |
538 | if (my @defined = grep defined, @$rhs) { |
539 | return $self->_expr_to_dq_ARRAYREF([ |
540 | { $k => { $inop => \@defined } }, |
5b670507 |
541 | { $k => $nullop }, |
542 | ], $logic); |
39221d2b |
543 | } |
fc4b3e6d |
544 | return $self->_expr_to_dq_HASHREF({ $k => $nullop }); |
5b670507 |
545 | } |
bdf53200 |
546 | return $self->_literal_to_dq( |
547 | $op =~ /^NOT/ ? $self->{sqltrue} : $self->{sqlfalse} |
548 | ) unless @$rhs; |
a82e41dc |
549 | return $self->_op_to_dq( |
550 | $op, $self->_ident_to_dq($k), map $self->_expr_to_dq($_), @$rhs |
551 | ) |
2e50f418 |
552 | } elsif ($op =~ s/^NOT (?!R?LIKE)//) { |
a82e41dc |
553 | return $self->_where_hashpair_to_dq(-not => { $k => { $op => $rhs } }); |
554 | } elsif ($op eq 'IDENT') { |
555 | return $self->_op_to_dq( |
556 | $self->{cmp}, $self->_ident_to_dq($k), $self->_ident_to_dq($rhs) |
557 | ); |
558 | } elsif ($op eq 'VALUE') { |
559 | return $self->_op_to_dq( |
560 | $self->{cmp}, $self->_ident_to_dq($k), $self->_value_to_dq($rhs) |
561 | ); |
562 | } elsif (!defined($rhs)) { |
563 | my $null_op = do { |
2e50f418 |
564 | warn "Supplying an undefined argument to '$op' is deprecated" |
565 | if $op =~ $self->like_op or $op =~ $self->not_like_op; |
566 | if ($op =~ $self->equality_op or $op =~ $self->like_op or $op eq 'IS') { |
a82e41dc |
567 | 'IS NULL' |
c8d97b3d |
568 | } elsif ( |
569 | $op =~ $self->inequality_op or $op =~ $self->not_like_op |
570 | or |
571 | $op eq 'IS NOT' or $op eq 'NOT' |
572 | ) { |
a82e41dc |
573 | 'IS NOT NULL' |
574 | } else { |
575 | die "Can't do undef -> NULL transform for operator ${op}"; |
576 | } |
577 | }; |
578 | return $self->_op_to_dq($null_op, $self->_ident_to_dq($k)); |
579 | } |
580 | if (ref($rhs) eq 'ARRAY') { |
581 | if (!@$rhs) { |
2e50f418 |
582 | if ($op =~ $self->like_op or $op =~ $self->not_like_op) { |
583 | warn "Supplying an empty arrayref to '$op' is deprecated"; |
584 | } elsif ($op !~ $self->equality_op and $op !~ $self->inequality_op) { |
585 | die "operator '$op' applied on an empty array (field '$k')"; |
586 | } |
a82e41dc |
587 | return $self->_literal_to_dq( |
2e50f418 |
588 | ($op =~ $self->inequality_op or $op =~ $self->not_like_op) |
589 | ? $self->{sqltrue} : $self->{sqlfalse} |
a82e41dc |
590 | ); |
591 | } elsif (defined($rhs->[0]) and $rhs->[0] =~ /^-(and|or)$/i) { |
592 | return $self->_expr_to_dq_ARRAYREF([ |
593 | map +{ $k => { $op => $_ } }, @{$rhs}[1..$#$rhs] |
594 | ], uc($1)); |
595 | } elsif ($op =~ /^-(?:AND|OR|NEST)_?\d+/) { |
596 | die "Use of [and|or|nest]_N modifiers is no longer supported"; |
2e50f418 |
597 | } elsif (@$rhs > 1 and ($op =~ $self->inequality_op or $op =~ $self->not_like_op)) { |
598 | warn "A multi-element arrayref as an argument to the inequality op '$op' " |
599 | . 'is technically equivalent to an always-true 1=1 (you probably wanted ' |
600 | . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)"; |
a82e41dc |
601 | } |
602 | return $self->_expr_to_dq_ARRAYREF([ |
603 | map +{ $k => { $op => $_ } }, @$rhs |
604 | ]); |
605 | } |
606 | return $self->_op_to_dq( |
607 | $op, $self->_ident_to_dq($k), $self->_expr_to_dq($rhs) |
608 | ); |
609 | } |
610 | } |
611 | |
612 | sub _order_by_to_dq { |
36e3ea6c |
613 | my ($self, $arg, $dir, $nulls, $from) = @_; |
a82e41dc |
614 | |
615 | return unless $arg; |
616 | |
4caa4620 |
617 | my $dq = Order( |
618 | undef, |
619 | (defined($dir) ? (!!($dir =~ /desc/i)) : undef), |
e1ba0ad9 |
620 | $nulls, |
4caa4620 |
621 | ($from ? ($from) : undef), |
622 | ); |
a82e41dc |
623 | |
624 | if (!ref($arg)) { |
625 | $dq->{by} = $self->_ident_to_dq($arg); |
626 | } elsif (ref($arg) eq 'ARRAY') { |
627 | return unless @$arg; |
628 | local our $Order_Inner unless our $Order_Recursing; |
629 | local $Order_Recursing = 1; |
630 | my ($outer, $inner); |
631 | foreach my $member (@$arg) { |
632 | local $Order_Inner; |
36e3ea6c |
633 | my $next = $self->_order_by_to_dq($member, $dir, $nulls, $from); |
a82e41dc |
634 | $outer ||= $next; |
635 | $inner->{from} = $next if $inner; |
636 | $inner = $Order_Inner || $next; |
637 | } |
638 | $Order_Inner = $inner; |
639 | return $outer; |
640 | } elsif (ref($arg) eq 'REF' and ref($$arg) eq 'ARRAY') { |
641 | $dq->{by} = $self->_literal_to_dq($$arg); |
02202b68 |
642 | } elsif (ref($arg) eq 'REF' and ref($$arg) eq 'HASH') { |
643 | $dq->{by} = $$arg; |
a82e41dc |
644 | } elsif (ref($arg) eq 'SCALAR') { |
8b9b83ae |
645 | |
f2a0d52b |
646 | # < mst> right, but if it doesn't match that, it goes "ok, right, not sure, |
8b9b83ae |
647 | # totally leaving this untouched as a literal" |
648 | # < mst> so I -think- it's relatively robust |
649 | # < ribasushi> right, it's relatively safe then |
650 | # < ribasushi> is this regex centralized? |
651 | # < mst> it only exists in _order_by_to_dq in SQL::Abstract::Converter |
f2a0d52b |
652 | # < mst> it only exists because you were kind enough to support new |
8b9b83ae |
653 | # dbihacks crack combined with old literal order_by crack |
654 | # < ribasushi> heh :) |
655 | |
c30db4b6 |
656 | # this should take into account our quote char and name sep |
657 | |
658 | my $match_ident = '\w+(?:\.\w+)*'; |
659 | |
660 | if (my ($ident, $dir) = $$arg =~ /^(${match_ident})(?:\s+(desc|asc))?$/i) { |
3d82b6c9 |
661 | $dq->{by} = $self->_ident_to_dq($ident); |
662 | $dq->{reverse} = 1 if $dir and lc($dir) eq 'desc'; |
663 | } else { |
664 | $dq->{by} = $self->_literal_to_dq($$arg); |
665 | } |
a82e41dc |
666 | } elsif (ref($arg) eq 'HASH') { |
36e3ea6c |
667 | return () unless %$arg; |
668 | |
669 | my ($direction, $val); |
670 | foreach my $key (keys %$arg) { |
671 | if ( $key =~ /^-(desc|asc)/i ) { |
672 | die "hash passed to _order_by_to_dq must have exactly one of -desc or -asc" |
673 | if defined $direction; |
674 | $direction = $1; |
675 | $val = $arg->{$key}; |
676 | } elsif ($key =~ /^-nulls$/i) { |
677 | $nulls = $arg->{$key}; |
e1ba0ad9 |
678 | die "invalid value for -nulls" unless $nulls =~ /^(?:first|last|none)$/i; |
36e3ea6c |
679 | } else { |
c5caf045 |
680 | die "invalid key ${key} in hash passed to _order_by_to_dq"; |
36e3ea6c |
681 | } |
682 | } |
a82e41dc |
683 | |
36e3ea6c |
684 | die "hash passed to _order_by_to_dq must have exactly one of -desc or -asc" |
685 | unless defined $direction; |
a82e41dc |
686 | |
36e3ea6c |
687 | return $self->_order_by_to_dq($val, $direction, $nulls, $from); |
a82e41dc |
688 | } else { |
689 | die "Can't handle $arg in _order_by_to_dq"; |
690 | } |
691 | return $dq; |
692 | } |
693 | |
694 | sub _table_to_dq { |
695 | my ($self, $from) = @_; |
696 | if (ref($from) eq 'ARRAY') { |
697 | die "Empty FROM list" unless my @f = @$from; |
698 | my $dq = $self->_table_to_dq(shift @f); |
699 | while (my $x = shift @f) { |
4caa4620 |
700 | $dq = Join( |
701 | $dq, |
702 | $self->_table_to_dq($x), |
703 | ); |
a82e41dc |
704 | } |
705 | $dq; |
706 | } elsif (ref($from) eq 'SCALAR' or (ref($from) eq 'REF')) { |
707 | $self->_literal_to_dq($$from); |
708 | } else { |
709 | $self->_ident_to_dq($from); |
710 | } |
711 | } |
712 | |
713 | # And bindtype |
714 | sub _bindtype (@) { |
715 | #my ($self, $col, @vals) = @_; |
716 | |
717 | #LDNOTE : changed original implementation below because it did not make |
718 | # sense when bindtype eq 'columns' and @vals > 1. |
719 | # return $self->{bindtype} eq 'columns' ? [ $col, @vals ] : @vals; |
720 | |
721 | # called often - tighten code |
722 | return $_[0]->bind_meta |
723 | ? map {[$_[1], $_]} @_[2 .. $#_] |
724 | : @_[2 .. $#_] |
725 | ; |
726 | } |
727 | |
728 | # Dies if any element of @bind is not in [colname => value] format |
729 | # if bindtype is 'columns'. |
730 | sub _assert_bindval_matches_bindtype { |
731 | # my ($self, @bind) = @_; |
732 | my $self = shift; |
733 | if ($self->bind_meta) { |
734 | for (@_) { |
735 | if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) { |
736 | die "bindtype 'columns' selected, you need to pass: [column_name => bind_value]" |
737 | } |
738 | } |
739 | } |
740 | } |
741 | |
742 | # Fix SQL case, if so requested |
743 | sub _sqlcase { |
744 | return $_[0]->lower_case ? $_[1] : uc($_[1]); |
745 | } |
746 | |
747 | 1; |