Switch defaults to either bare values or quote_sub
[dbsrgits/SQL-Abstract.git] / lib / SQL / Abstract / Converter.pm
CommitLineData
a82e41dc 1package SQL::Abstract::Converter;
2
3use Carp ();
4use List::Util ();
5use Scalar::Util ();
4caa4620 6use Data::Query::ExprHelpers;
9ea5bb0f 7use Sub::Quote 'quote_sub';
a82e41dc 8use Moo;
8b9b83ae 9use namespace::clean;
a82e41dc 10
11has renderer_will_quote => (
12 is => 'ro'
13);
14
15has lower_case => (
4caa4620 16 is => 'ro'
a82e41dc 17);
18
19has default_logic => (
9ea5bb0f 20 is => 'ro', coerce => quote_sub( 'uc($_[0])' ), default => 'OR'
a82e41dc 21);
22
23has bind_meta => (
9ea5bb0f 24 is => 'ro', default => 1
a82e41dc 25);
26
9ea5bb0f 27has cmp => (is => 'ro', default => '=' );
a82e41dc 28
9ea5bb0f 29has sqltrue => (is => 'ro', default => '1=1' );
30has sqlfalse => (is => 'ro', default => '0=1' );
a82e41dc 31
9ea5bb0f 32has special_ops => (is => 'ro', default => quote_sub( '[]' ) );
a82e41dc 33
34# XXX documented but I don't current fail any tests not using it
9ea5bb0f 35has unary_ops => (is => 'ro', default => quote_sub( '[]' ) );
a82e41dc 36
37has 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
48has identifier_sep => (
9ea5bb0f 49 is => 'ro', default => '.',
a82e41dc 50);
51
9ea5bb0f 52has always_quote => (is => 'ro', default => 1);
a82e41dc 53
54has convert => (is => 'ro');
55
56has array_datatypes => (is => 'ro');
57
2e50f418 58has equality_op => (
59 is => 'ro',
9ea5bb0f 60 default => quote_sub( q{ qr/^ (?: = ) $/ix } ),
2e50f418 61);
62
63has inequality_op => (
64 is => 'ro',
9ea5bb0f 65 default => quote_sub( q{ qr/^ (?: != | <> ) $/ix } ),
2e50f418 66);
67
68has like_op => (
69 is => 'ro',
9ea5bb0f 70 default => quote_sub( q{ qr/^ (?: is \s+ )? r?like $/xi } ),
2e50f418 71);
72
73has 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 79sub _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
86sub _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
97sub _value_to_dq {
98 my ($self, $value) = @_;
99 $self->_maybe_convert_dq(perl_scalar_value($value, our $Cur_Col_Meta));
100}
101
102sub _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
117sub _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
130sub _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
136sub _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
145sub _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
175sub _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
192sub _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
213sub _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
225sub _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 242sub _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
253sub _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
259sub _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
271sub _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
279sub _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 293my %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 305sub _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
338sub _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
365sub _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
385sub _where_to_dq_SCALAR {
386 shift->_value_to_dq(@_);
387}
388
389sub _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
439sub _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
612sub _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
694sub _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
714sub _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'.
730sub _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
743sub _sqlcase {
744 return $_[0]->lower_case ? $_[1] : uc($_[1]);
745}
746
7471;