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