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