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