Actually weaken Converter->sqla_instance ref
[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;
a82e41dc 7use Moo;
8b9b83ae 8use namespace::clean;
a82e41dc 9
10has renderer_will_quote => (
11 is => 'ro'
12);
13
14has lower_case => (
4caa4620 15 is => 'ro'
a82e41dc 16);
17
333eae18 18has legacy_convert_handler => (
19 is => 'ro'
20);
21has sqla_instance => (
c06cad46 22 is => 'ro', weak_ref => 1
333eae18 23);
24
a82e41dc 25has default_logic => (
26 is => 'ro', coerce => sub { uc($_[0]) }, default => sub { 'OR' }
27);
28
29has bind_meta => (
30 is => 'ro', default => sub { 1 }
31);
32
33has cmp => (is => 'ro', default => sub { '=' });
34
35has sqltrue => (is => 'ro', default => sub { '1=1' });
36has sqlfalse => (is => 'ro', default => sub { '0=1' });
37
38has special_ops => (is => 'ro', default => sub { [] });
39
40# XXX documented but I don't current fail any tests not using it
41has unary_ops => (is => 'ro', default => sub { [] });
42
43has injection_guard => (
44 is => 'ro',
45 default => sub {
46 qr/
47 \;
48 |
49 ^ \s* go \s
50 /xmi;
51 }
52);
53
54has identifier_sep => (
55 is => 'ro', default => sub { '.' },
56);
57
58has always_quote => (is => 'ro', default => sub { 1 });
59
60has convert => (is => 'ro');
61
62has array_datatypes => (is => 'ro');
63
2e50f418 64has equality_op => (
65 is => 'ro',
66 default => sub { qr/^ (?: = ) $/ix },
67);
68
69has inequality_op => (
70 is => 'ro',
71 default => sub { qr/^ (?: != | <> ) $/ix },
72);
73
74has like_op => (
75 is => 'ro',
76 default => sub { qr/^ (?: is \s+ )? r?like $/xi },
77);
78
79has not_like_op => (
80 is => 'ro',
81 default => sub { qr/^ (?: is \s+ )? not \s+ r?like $/xi },
82);
83
84
a82e41dc 85sub _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
92sub _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
103sub _value_to_dq {
104 my ($self, $value) = @_;
105 $self->_maybe_convert_dq(perl_scalar_value($value, our $Cur_Col_Meta));
106}
107
108sub _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
123sub _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
142sub _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
148sub _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
157sub _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
187sub _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
204sub _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
225sub _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
237sub _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 254sub _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
265sub _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
271sub _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
283sub _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
291sub _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 305my %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 317sub _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
350sub _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
377sub _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
397sub _where_to_dq_SCALAR {
398 shift->_value_to_dq(@_);
399}
400
401sub _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
451sub _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
624sub _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
706sub _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
726sub _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'.
742sub _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
755sub _sqlcase {
756 return $_[0]->lower_case ? $_[1] : uc($_[1]);
757}
758
7591;