1 package SQL::Abstract::Converter;
6 use Data::Query::ExprHelpers;
10 has renderer_will_quote => (
18 has default_logic => (
19 is => 'ro', coerce => sub { uc($_[0]) }, default => sub { 'OR' }
23 is => 'ro', default => sub { 1 }
26 has cmp => (is => 'ro', default => sub { '=' });
28 has sqltrue => (is => 'ro', default => sub { '1=1' });
29 has sqlfalse => (is => 'ro', default => sub { '0=1' });
31 has special_ops => (is => 'ro', default => sub { [] });
33 # XXX documented but I don't current fail any tests not using it
34 has unary_ops => (is => 'ro', default => sub { [] });
36 has injection_guard => (
47 has identifier_sep => (
48 is => 'ro', default => sub { '.' },
51 has always_quote => (is => 'ro', default => sub { 1 });
53 has convert => (is => 'ro');
55 has array_datatypes => (is => 'ro');
59 default => sub { qr/^ (?: = ) $/ix },
62 has inequality_op => (
64 default => sub { qr/^ (?: != | <> ) $/ix },
69 default => sub { qr/^ (?: is \s+ )? r?like $/xi },
74 default => sub { qr/^ (?: is \s+ )? not \s+ r?like $/xi },
79 my ($self, $literal) = @_;
81 ($literal, @bind) = @$literal if ref($literal) eq 'ARRAY';
82 Literal('SQL', $literal, [ $self->_bind_to_dq(@bind) ]);
86 my ($self, @bind) = @_;
90 $self->_assert_bindval_matches_bindtype(@bind);
91 map perl_scalar_value(reverse @$_), @bind
93 : map perl_scalar_value($_), @bind
97 my ($self, $value) = @_;
98 $self->_maybe_convert_dq(perl_scalar_value($value, our $Cur_Col_Meta));
102 my ($self, $ident) = @_;
103 $self->_assert_pass_injection_guard($ident)
104 unless $self->renderer_will_quote;
105 $self->_maybe_convert_dq(
107 if (my $sep = $self->identifier_sep) {
108 split /\Q$sep/, $ident
116 sub _maybe_convert_dq {
117 my ($self, $dq) = @_;
118 if (my $c = $self->{where_convert}) {
119 Operator({ 'SQL.Naive' => 'apply' }, [
120 Identifier($self->_sqlcase($c)),
130 my ($self, $op, @args) = @_;
131 $self->_assert_pass_injection_guard($op);
132 Operator({ 'SQL.Naive' => $op }, \@args);
135 sub _assert_pass_injection_guard {
136 if ($_[1] =~ $_[0]->{injection_guard}) {
137 my $class = ref $_[0];
138 die "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the "
139 . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own "
140 . "{injection_guard} attribute to ${class}->new()"
145 my ($self, $table, $data, $options) = @_;
146 my (@names, @values);
147 if (ref($data) eq 'HASH') {
148 @names = sort keys %$data;
149 foreach my $k (@names) {
150 local our $Cur_Col_Meta = $k;
151 push @values, $self->_mutation_rhs_to_dq($data->{$k});
153 } elsif (ref($data) eq 'ARRAY') {
154 local our $Cur_Col_Meta;
155 @values = map $self->_mutation_rhs_to_dq($_), @$data;
157 die "Not handled yet";
160 if (my $r_source = $options->{returning}) {
162 map +(ref($_) ? $self->_expr_to_dq($_) : $self->_ident_to_dq($_)),
163 (ref($r_source) eq 'ARRAY' ? @$r_source : $r_source),
167 (@names ? ([ map $self->_ident_to_dq($_), @names ]) : undef),
169 $self->_table_to_dq($table),
170 ($returning ? ($returning) : undef),
174 sub _mutation_rhs_to_dq {
176 if (ref($v) eq 'ARRAY') {
177 if ($self->{array_datatypes}) {
178 return $self->_value_to_dq($v);
180 $v = \do { my $x = $v };
182 if (ref($v) eq 'HASH') {
183 my ($op, $arg, @rest) = %$v;
185 die 'Operator calls in update/insert must be in the form { -op => $arg }'
186 if (@rest or not $op =~ /^\-/);
188 return $self->_expr_to_dq($v);
192 my ($self, $table, $data, $where) = @_;
194 die "Unsupported data type specified to \$sql->update"
195 unless ref $data eq 'HASH';
199 foreach my $k (sort keys %$data) {
201 local our $Cur_Col_Meta = $k;
202 push @set, [ $self->_ident_to_dq($k), $self->_mutation_rhs_to_dq($v) ];
207 $self->_where_to_dq($where),
208 $self->_table_to_dq($table),
213 my ($self, $table, undef, $where) = @_;
215 my $source_dq = $self->_table_to_dq($table);
217 if (my $where_dq = $self->_where_to_dq($where)) {
218 $source_dq = Where($where_dq, $source_dq);
226 my ($table, $fields, $where, $order) = @_;
228 my $source_dq = $self->_source_to_dq(@_);
230 my $ordered_dq = do {
232 $self->_order_by_to_dq($order, undef, undef, $source_dq);
238 return $self->_select_select_to_dq($fields, $ordered_dq);
241 sub _select_select_to_dq {
242 my ($self, $fields, $from_dq) = @_;
247 $self->_select_field_list_to_dq($fields),
252 sub _select_field_list_to_dq {
253 my ($self, $fields) = @_;
254 [ map $self->_select_field_to_dq($_),
255 ref($fields) eq 'ARRAY' ? @$fields : $fields ];
258 sub _select_field_to_dq {
259 my ($self, $field) = @_;
260 if (my $ref = ref($field)) {
261 if ($ref eq 'REF' and ref($$field) eq 'HASH') {
264 return $self->_literal_to_dq($$field);
267 return $self->_ident_to_dq($field)
271 my ($self, $table, $where) = @_;
273 $self->_where_to_dq($where),
274 $self->_table_to_dq($table),
279 my ($self, $where, $logic) = @_;
281 return undef unless defined($where);
283 # if we're given a simple string assume it's a literal
284 return $self->_literal_to_dq($where) if !ref($where);
286 # turn the convert misfeature on - only used in WHERE clauses
287 local $self->{where_convert} = $self->convert;
289 return $self->_expr_to_dq($where, $logic);
292 my %op_conversions = (
301 'defined' => 'IS NOT NULL',
305 my ($self, $where, $logic) = @_;
307 if (ref($where) eq 'ARRAY') {
308 return $self->_expr_to_dq_ARRAYREF($where, $logic);
309 } elsif (ref($where) eq 'HASH') {
310 return $self->_expr_to_dq_HASHREF($where, $logic);
312 ref($where) eq 'SCALAR'
313 or (ref($where) eq 'REF' and ref($$where) eq 'ARRAY')
315 return $self->_literal_to_dq($$where);
316 } elsif (ref($where) eq 'REF' and ref($$where) eq 'HASH') {
320 and not $_->{operator}{'SQL.Naive'}
321 and my $op = $_->{operator}{'Perl'}
323 my $sql_op = $op_conversions{$op} || uc($op);
326 operator => { 'SQL.Naive' => $sql_op }
331 } elsif (!ref($where) or Scalar::Util::blessed($where)) {
332 return $self->_value_to_dq($where);
334 die "Can't handle $where";
337 sub _expr_to_dq_ARRAYREF {
338 my ($self, $where, $logic) = @_;
340 $logic = uc($logic || $self->default_logic || 'OR');
341 $logic eq 'AND' or $logic eq 'OR' or die "unknown logic: $logic";
343 return unless @$where;
345 my ($first, @rest) = @$where;
347 return $self->_expr_to_dq($first) unless @rest;
351 $self->_where_hashpair_to_dq($first => shift(@rest));
353 $self->_expr_to_dq($first);
357 return $self->_expr_to_dq_ARRAYREF(\@rest, $logic) unless $first_dq;
360 $logic, $first_dq, $self->_expr_to_dq_ARRAYREF(\@rest, $logic)
364 sub _expr_to_dq_HASHREF {
365 my ($self, $where, $logic) = @_;
367 $logic = uc($logic) if $logic;
370 $self->_where_hashpair_to_dq($_ => $where->{$_}, $logic)
373 return $dq[0] unless @dq > 1;
375 my $final = pop(@dq);
377 foreach my $dq (reverse @dq) {
378 $final = $self->_op_to_dq($logic||'AND', $dq, $final);
384 sub _where_to_dq_SCALAR {
385 shift->_value_to_dq(@_);
389 my ($self, $op, $v) = @_;
390 my @args = map $self->_expr_to_dq($_), (ref($v) eq 'ARRAY' ? @$v : $v);
392 # Ok. Welcome to stupid compat code land. An SQLA expr that would in the
393 # absence of this piece of crazy render to:
399 # { -a => { -b => { -c => $x } } }
401 # actually needs to render to:
405 # because SQL sucks, and databases are hateful, and SQLA is Just That DWIM.
407 # However, we don't want to catch 'A(x)' and turn it into 'A x'
409 # So the way we deal with this is to go through all our arguments, and
410 # then if the argument is -also- an apply, i.e. at least 'B', we check
411 # its arguments - and if there's only one of them, and that isn't an apply,
412 # then we convert to the bareword form. The end result should be:
415 # A( B( x ) ) -> A( B x )
416 # A( B( C( x ) ) ) -> A( B( C x ) )
417 # A( B( x + y ) ) -> A( B( x + y ) )
418 # A( B( x, y ) ) -> A( B( x, y ) )
420 # If this turns out not to be quite right, please add additional tests
421 # to either 01generate.t or 02where.t *and* update this comment.
423 foreach my $arg (@args) {
425 is_Operator($arg) and $arg->{operator}{'SQL.Naive'} eq 'apply'
426 and @{$arg->{args}} == 2 and !is_Operator($arg->{args}[1])
429 $arg->{operator}{'SQL.Naive'} = (shift @{$arg->{args}})->{elements}->[0];
432 $self->_assert_pass_injection_guard($op);
433 return $self->_op_to_dq(
434 apply => $self->_ident_to_dq($op), @args
438 sub _where_hashpair_to_dq {
439 my ($self, $k, $v, $logic) = @_;
441 if ($k =~ /^-(.*)/s) {
443 if ($op eq 'AND' or $op eq 'OR') {
444 return $self->_expr_to_dq($v, $op);
445 } elsif ($op eq 'NEST') {
446 return $self->_expr_to_dq($v);
447 } elsif ($op eq 'NOT') {
448 return $self->_op_to_dq(NOT => $self->_expr_to_dq($v));
449 } elsif ($op eq 'BOOL') {
450 return ref($v) ? $self->_expr_to_dq($v) : $self->_ident_to_dq($v);
451 } elsif ($op eq 'NOT_BOOL') {
452 return $self->_op_to_dq(
453 NOT => ref($v) ? $self->_expr_to_dq($v) : $self->_ident_to_dq($v)
455 } elsif ($op eq 'IDENT') {
456 return $self->_ident_to_dq($v);
457 } elsif ($op eq 'VALUE') {
458 return $self->_value_to_dq($v);
459 } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+/) {
460 die "Use of [and|or|nest]_N modifiers is no longer supported";
462 return $self->_apply_to_dq($op, $v);
465 local our $Cur_Col_Meta = $k;
466 if (ref($v) eq 'ARRAY') {
468 return $self->_literal_to_dq($self->{sqlfalse});
469 } elsif (defined($v->[0]) && $v->[0] =~ /-(and|or)/i) {
470 return $self->_expr_to_dq_ARRAYREF([
471 map +{ $k => $_ }, @{$v}[1..$#$v]
474 return $self->_expr_to_dq_ARRAYREF([
475 map +{ $k => $_ }, @$v
477 } elsif (ref($v) eq 'SCALAR' or (ref($v) eq 'REF' and ref($$v) eq 'ARRAY')) {
478 return Literal('SQL', [ $self->_ident_to_dq($k), $self->_literal_to_dq($$v) ]);
480 my ($op, $rhs) = do {
481 if (ref($v) eq 'HASH') {
483 return $self->_expr_to_dq_ARRAYREF([
484 map +{ $k => { $_ => $v->{$_} } }, sort keys %$v
487 my ($op, $value) = %$v;
488 s/^-//, s/_/ /g for $op;
489 if ($op =~ /^(?:and|or)$/i) {
490 return $self->_expr_to_dq({ $k => $value }, $op);
492 my $special_op = List::Util::first {$op =~ $_->{regex}}
493 @{$self->{special_ops}}
495 return $self->_literal_to_dq(
496 [ $special_op->{handler}->($k, $op, $value) ]
498 } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+$/i) {
499 die "Use of [and|or|nest]_N modifiers is no longer supported";
506 if ($op eq 'BETWEEN' or $op eq 'IN' or $op eq 'NOT IN' or $op eq 'NOT BETWEEN') {
507 die "Argument passed to the '$op' operator can not be undefined" unless defined $rhs;
508 $rhs = [$rhs] unless ref $rhs;
509 if (ref($rhs) ne 'ARRAY') {
510 if ($op =~ /^(?:NOT )?IN$/) {
511 # have to add parens if none present because -in => \"SELECT ..."
512 # got documented. mst hates everything.
513 if (ref($rhs) eq 'SCALAR') {
515 1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
517 } elsif (ref($rhs) eq 'REF') {
518 if (ref($$rhs) eq 'ARRAY') {
519 my ($x, @rest) = @{$$rhs};
520 1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
521 $rhs = \[ $x, @rest ];
522 } elsif (ref($$rhs) eq 'HASH') {
523 return $self->_op_to_dq($op, $self->_ident_to_dq($k), $$rhs);
527 return $self->_op_to_dq(
528 $op, $self->_ident_to_dq($k), $self->_literal_to_dq($$rhs)
531 die "Operator '$op' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref"
532 if $op =~ /^(?:NOT )?BETWEEN$/ and (@$rhs != 2 or grep !defined, @$rhs);
533 if (grep !defined, @$rhs) {
534 my ($inop, $logic, $nullop) = $op =~ /^NOT/
535 ? (-not_in => AND => { '!=' => undef })
536 : (-in => OR => undef);
537 if (my @defined = grep defined, @$rhs) {
538 return $self->_expr_to_dq_ARRAYREF([
539 { $k => { $inop => \@defined } },
543 return $self->_expr_to_dq_HASHREF({ $k => $nullop });
545 return $self->_literal_to_dq(
546 $op =~ /^NOT/ ? $self->{sqltrue} : $self->{sqlfalse}
548 return $self->_op_to_dq(
549 $op, $self->_ident_to_dq($k), map $self->_expr_to_dq($_), @$rhs
551 } elsif ($op =~ s/^NOT (?!R?LIKE)//) {
552 return $self->_where_hashpair_to_dq(-not => { $k => { $op => $rhs } });
553 } elsif ($op eq 'IDENT') {
554 return $self->_op_to_dq(
555 $self->{cmp}, $self->_ident_to_dq($k), $self->_ident_to_dq($rhs)
557 } elsif ($op eq 'VALUE') {
558 return $self->_op_to_dq(
559 $self->{cmp}, $self->_ident_to_dq($k), $self->_value_to_dq($rhs)
561 } elsif (!defined($rhs)) {
563 warn "Supplying an undefined argument to '$op' is deprecated"
564 if $op =~ $self->like_op or $op =~ $self->not_like_op;
565 if ($op =~ $self->equality_op or $op =~ $self->like_op or $op eq 'IS') {
567 } elsif ($op =~ $self->inequality_op or $op =~ $self->not_like_op or $op eq 'IS NOT') {
570 die "Can't do undef -> NULL transform for operator ${op}";
573 return $self->_op_to_dq($null_op, $self->_ident_to_dq($k));
575 if (ref($rhs) eq 'ARRAY') {
577 if ($op =~ $self->like_op or $op =~ $self->not_like_op) {
578 warn "Supplying an empty arrayref to '$op' is deprecated";
579 } elsif ($op !~ $self->equality_op and $op !~ $self->inequality_op) {
580 die "operator '$op' applied on an empty array (field '$k')";
582 return $self->_literal_to_dq(
583 ($op =~ $self->inequality_op or $op =~ $self->not_like_op)
584 ? $self->{sqltrue} : $self->{sqlfalse}
586 } elsif (defined($rhs->[0]) and $rhs->[0] =~ /^-(and|or)$/i) {
587 return $self->_expr_to_dq_ARRAYREF([
588 map +{ $k => { $op => $_ } }, @{$rhs}[1..$#$rhs]
590 } elsif ($op =~ /^-(?:AND|OR|NEST)_?\d+/) {
591 die "Use of [and|or|nest]_N modifiers is no longer supported";
592 } elsif (@$rhs > 1 and ($op =~ $self->inequality_op or $op =~ $self->not_like_op)) {
593 warn "A multi-element arrayref as an argument to the inequality op '$op' "
594 . 'is technically equivalent to an always-true 1=1 (you probably wanted '
595 . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)";
597 return $self->_expr_to_dq_ARRAYREF([
598 map +{ $k => { $op => $_ } }, @$rhs
601 return $self->_op_to_dq(
602 $op, $self->_ident_to_dq($k), $self->_expr_to_dq($rhs)
607 sub _order_by_to_dq {
608 my ($self, $arg, $dir, $nulls, $from) = @_;
614 (defined($dir) ? (!!($dir =~ /desc/i)) : undef),
616 ($from ? ($from) : undef),
620 $dq->{by} = $self->_ident_to_dq($arg);
621 } elsif (ref($arg) eq 'ARRAY') {
623 local our $Order_Inner unless our $Order_Recursing;
624 local $Order_Recursing = 1;
626 foreach my $member (@$arg) {
628 my $next = $self->_order_by_to_dq($member, $dir, $nulls, $from);
630 $inner->{from} = $next if $inner;
631 $inner = $Order_Inner || $next;
633 $Order_Inner = $inner;
635 } elsif (ref($arg) eq 'REF' and ref($$arg) eq 'ARRAY') {
636 $dq->{by} = $self->_literal_to_dq($$arg);
637 } elsif (ref($arg) eq 'REF' and ref($$arg) eq 'HASH') {
639 } elsif (ref($arg) eq 'SCALAR') {
641 # < mst> right, but if it doesn't match that, it goes "ok, right, not sure,
642 # totally leaving this untouched as a literal"
643 # < mst> so I -think- it's relatively robust
644 # < ribasushi> right, it's relatively safe then
645 # < ribasushi> is this regex centralized?
646 # < mst> it only exists in _order_by_to_dq in SQL::Abstract::Converter
647 # < mst> it only exists because you were kind enough to support new
648 # dbihacks crack combined with old literal order_by crack
649 # < ribasushi> heh :)
651 # this should take into account our quote char and name sep
653 my $match_ident = '\w+(?:\.\w+)*';
655 if (my ($ident, $dir) = $$arg =~ /^(${match_ident})(?:\s+(desc|asc))?$/i) {
656 $dq->{by} = $self->_ident_to_dq($ident);
657 $dq->{reverse} = 1 if $dir and lc($dir) eq 'desc';
659 $dq->{by} = $self->_literal_to_dq($$arg);
661 } elsif (ref($arg) eq 'HASH') {
662 return () unless %$arg;
664 my ($direction, $val);
665 foreach my $key (keys %$arg) {
666 if ( $key =~ /^-(desc|asc)/i ) {
667 die "hash passed to _order_by_to_dq must have exactly one of -desc or -asc"
668 if defined $direction;
671 } elsif ($key =~ /^-nulls$/i) {
672 $nulls = $arg->{$key};
673 die "invalid value for -nulls" unless $nulls =~ /^(?:first|last|none)$/i;
675 die "invalid key ${key} in hash passed to _order_by_to_dq";
679 die "hash passed to _order_by_to_dq must have exactly one of -desc or -asc"
680 unless defined $direction;
682 return $self->_order_by_to_dq($val, $direction, $nulls, $from);
684 die "Can't handle $arg in _order_by_to_dq";
690 my ($self, $from) = @_;
691 if (ref($from) eq 'ARRAY') {
692 die "Empty FROM list" unless my @f = @$from;
693 my $dq = $self->_table_to_dq(shift @f);
694 while (my $x = shift @f) {
697 $self->_table_to_dq($x),
701 } elsif (ref($from) eq 'SCALAR' or (ref($from) eq 'REF')) {
702 $self->_literal_to_dq($$from);
704 $self->_ident_to_dq($from);
710 #my ($self, $col, @vals) = @_;
712 #LDNOTE : changed original implementation below because it did not make
713 # sense when bindtype eq 'columns' and @vals > 1.
714 # return $self->{bindtype} eq 'columns' ? [ $col, @vals ] : @vals;
716 # called often - tighten code
717 return $_[0]->bind_meta
718 ? map {[$_[1], $_]} @_[2 .. $#_]
723 # Dies if any element of @bind is not in [colname => value] format
724 # if bindtype is 'columns'.
725 sub _assert_bindval_matches_bindtype {
726 # my ($self, @bind) = @_;
728 if ($self->bind_meta) {
730 if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
731 die "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
737 # Fix SQL case, if so requested
739 return $_[0]->lower_case ? $_[1] : uc($_[1]);