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');
58 my ($self, $literal) = @_;
60 ($literal, @bind) = @$literal if ref($literal) eq 'ARRAY';
61 Literal('SQL', $literal, [ $self->_bind_to_dq(@bind) ]);
65 my ($self, @bind) = @_;
69 $self->_assert_bindval_matches_bindtype(@bind);
70 map perl_scalar_value(reverse @$_), @bind
72 : map perl_scalar_value($_), @bind
76 my ($self, $value) = @_;
77 $self->_maybe_convert_dq(perl_scalar_value($value, our $Cur_Col_Meta));
81 my ($self, $ident) = @_;
82 $self->_assert_pass_injection_guard($ident)
83 unless $self->renderer_will_quote;
84 $self->_maybe_convert_dq(Identifier(split /\Q${\$self->identifier_sep}/, $ident));
87 sub _maybe_convert_dq {
89 if (my $c = $self->{where_convert}) {
90 Operator({ 'SQL.Naive' => 'apply' }, [
91 Identifier($self->_sqlcase($c)),
101 my ($self, $op, @args) = @_;
102 $self->_assert_pass_injection_guard($op);
103 Operator({ 'SQL.Naive' => $op }, \@args);
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()"
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});
124 } elsif (ref($data) eq 'ARRAY') {
125 local our $Cur_Col_Meta;
126 @values = map $self->_mutation_rhs_to_dq($_), @$data;
128 die "Not handled yet";
131 if (my $r_source = $options->{returning}) {
133 map +(ref($_) ? $self->_expr_to_dq($_) : $self->_ident_to_dq($_)),
134 (ref($r_source) eq 'ARRAY' ? @$r_source : $r_source),
138 (@names ? ([ map $self->_ident_to_dq($_), @names ]) : undef),
140 $self->_table_to_dq($table),
141 ($returning ? ($returning) : undef),
145 sub _mutation_rhs_to_dq {
147 if (ref($v) eq 'ARRAY') {
148 if ($self->{array_datatypes}) {
149 return $self->_value_to_dq($v);
151 $v = \do { my $x = $v };
153 if (ref($v) eq 'HASH') {
154 my ($op, $arg, @rest) = %$v;
156 die 'Operator calls in update/insert must be in the form { -op => $arg }'
157 if (@rest or not $op =~ /^\-(.+)/);
159 return $self->_expr_to_dq($v);
163 my ($self, $table, $data, $where) = @_;
165 die "Unsupported data type specified to \$sql->update"
166 unless ref $data eq 'HASH';
170 foreach my $k (sort keys %$data) {
172 local our $Cur_Col_Meta = $k;
173 push @set, [ $self->_ident_to_dq($k), $self->_mutation_rhs_to_dq($v) ];
178 $self->_where_to_dq($where),
179 $self->_table_to_dq($table),
184 my ($self, $table, undef, $where) = @_;
186 my $source_dq = $self->_table_to_dq($table);
188 if (my $where_dq = $self->_where_to_dq($where)) {
189 $source_dq = Where($where_dq, $source_dq);
197 my ($table, $fields, $where, $order) = @_;
199 my $source_dq = $self->_source_to_dq(@_);
201 my $ordered_dq = do {
203 $self->_order_by_to_dq($order, undef, $source_dq);
209 return $self->_select_select_to_dq($fields, $ordered_dq);
212 sub _select_select_to_dq {
213 my ($self, $fields, $from_dq) = @_;
218 $self->_select_field_list_to_dq($fields),
223 sub _select_field_list_to_dq {
224 my ($self, $fields) = @_;
225 [ map $self->_select_field_to_dq($_),
226 ref($fields) eq 'ARRAY' ? @$fields : $fields ];
229 sub _select_field_to_dq {
230 my ($self, $field) = @_;
231 if (my $ref = ref($field)) {
232 if ($ref eq 'REF' and ref($$field) eq 'HASH') {
235 return $self->_literal_to_dq($$field);
238 return $self->_ident_to_dq($field)
242 my ($self, $table, $where) = @_;
244 $self->_where_to_dq($where),
245 $self->_table_to_dq($table),
250 my ($self, $where, $logic) = @_;
252 return undef unless defined($where);
254 # if we're given a simple string assume it's a literal
255 return $self->_literal_to_dq($where) if !ref($where);
257 # turn the convert misfeature on - only used in WHERE clauses
258 local $self->{where_convert} = $self->convert;
260 return $self->_expr_to_dq($where, $logic);
264 my ($self, $where, $logic) = @_;
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);
271 ref($where) eq 'SCALAR'
272 or (ref($where) eq 'REF' and ref($$where) eq 'ARRAY')
274 return $self->_literal_to_dq($$where);
275 } elsif (ref($where) eq 'REF' and ref($$where) eq 'HASH') {
277 } elsif (!ref($where) or Scalar::Util::blessed($where)) {
278 return $self->_value_to_dq($where);
280 die "Can't handle $where";
283 sub _expr_to_dq_ARRAYREF {
284 my ($self, $where, $logic) = @_;
286 $logic = uc($logic || $self->default_logic || 'OR');
287 $logic eq 'AND' or $logic eq 'OR' or die "unknown logic: $logic";
289 return unless @$where;
291 my ($first, @rest) = @$where;
293 return $self->_expr_to_dq($first) unless @rest;
297 $self->_where_hashpair_to_dq($first => shift(@rest));
299 $self->_expr_to_dq($first);
303 return $self->_expr_to_dq_ARRAYREF(\@rest, $logic) unless $first_dq;
306 $logic, $first_dq, $self->_expr_to_dq_ARRAYREF(\@rest, $logic)
310 sub _expr_to_dq_HASHREF {
311 my ($self, $where, $logic) = @_;
313 $logic = uc($logic) if $logic;
316 $self->_where_hashpair_to_dq($_ => $where->{$_}, $logic)
319 return $dq[0] unless @dq > 1;
321 my $final = pop(@dq);
323 foreach my $dq (reverse @dq) {
324 $final = $self->_op_to_dq($logic||'AND', $dq, $final);
330 sub _where_to_dq_SCALAR {
331 shift->_value_to_dq(@_);
335 my ($self, $op, $v) = @_;
336 my @args = map $self->_expr_to_dq($_), (ref($v) eq 'ARRAY' ? @$v : $v);
338 # Ok. Welcome to stupid compat code land. An SQLA expr that would in the
339 # absence of this piece of crazy render to:
345 # { -a => { -b => { -c => $x } } }
347 # actually needs to render to:
351 # because SQL sucks, and databases are hateful, and SQLA is Just That DWIM.
353 # However, we don't want to catch 'A(x)' and turn it into 'A x'
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:
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 ) )
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.
369 foreach my $arg (@args) {
371 is_Operator($arg) and $arg->{operator}{'SQL.Naive'} eq 'apply'
372 and @{$arg->{args}} == 2 and !is_Operator($arg->{args}[1])
375 $arg->{operator}{'SQL.Naive'} = (shift @{$arg->{args}})->{elements}->[0];
378 $self->_assert_pass_injection_guard($op);
379 return $self->_op_to_dq(
380 apply => $self->_ident_to_dq($op), @args
384 sub _where_hashpair_to_dq {
385 my ($self, $k, $v, $logic) = @_;
387 if ($k =~ /^-(.*)/s) {
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)
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";
408 return $self->_apply_to_dq($op, $v);
411 local our $Cur_Col_Meta = $k;
412 if (ref($v) eq 'ARRAY') {
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]
420 return $self->_expr_to_dq_ARRAYREF([
421 map +{ $k => $_ }, @$v
423 } elsif (ref($v) eq 'SCALAR' or (ref($v) eq 'REF' and ref($$v) eq 'ARRAY')) {
424 return Literal('SQL', [ $self->_ident_to_dq($k), $self->_literal_to_dq($$v) ]);
426 my ($op, $rhs) = do {
427 if (ref($v) eq 'HASH') {
429 return $self->_expr_to_dq_ARRAYREF([
430 map +{ $k => { $_ => $v->{$_} } }, sort keys %$v
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);
438 my $special_op = List::Util::first {$op =~ $_->{regex}}
439 @{$self->{special_ops}}
441 return $self->_literal_to_dq(
442 [ $special_op->{handler}->($k, $op, $value) ]
444 } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+$/i) {
445 die "Use of [and|or|nest]_N modifiers is no longer supported";
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') {
455 # have to add parens if none present because -in => \"SELECT ..."
456 # got documented. mst hates everything.
457 if (ref($rhs) eq 'SCALAR') {
459 1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
462 my ($x, @rest) = @{$$rhs};
463 1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
464 $rhs = \[ $x, @rest ];
467 return $self->_op_to_dq(
468 $op, $self->_ident_to_dq($k), $self->_literal_to_dq($$rhs)
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
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)
481 } elsif ($op eq 'VALUE') {
482 return $self->_op_to_dq(
483 $self->{cmp}, $self->_ident_to_dq($k), $self->_value_to_dq($rhs)
485 } elsif (!defined($rhs)) {
487 if ($op eq '=' or $op eq 'LIKE') {
489 } elsif ($op eq '!=') {
492 die "Can't do undef -> NULL transform for operator ${op}";
495 return $self->_op_to_dq($null_op, $self->_ident_to_dq($k));
497 if (ref($rhs) eq 'ARRAY') {
499 return $self->_literal_to_dq(
500 $op eq '!=' ? $self->{sqltrue} : $self->{sqlfalse}
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]
506 } elsif ($op =~ /^-(?:AND|OR|NEST)_?\d+/) {
507 die "Use of [and|or|nest]_N modifiers is no longer supported";
509 return $self->_expr_to_dq_ARRAYREF([
510 map +{ $k => { $op => $_ } }, @$rhs
513 return $self->_op_to_dq(
514 $op, $self->_ident_to_dq($k), $self->_expr_to_dq($rhs)
519 sub _order_by_to_dq {
520 my ($self, $arg, $dir, $from) = @_;
526 (defined($dir) ? (!!($dir =~ /desc/i)) : undef),
527 ($from ? ($from) : undef),
531 $dq->{by} = $self->_ident_to_dq($arg);
532 } elsif (ref($arg) eq 'ARRAY') {
534 local our $Order_Inner unless our $Order_Recursing;
535 local $Order_Recursing = 1;
537 foreach my $member (@$arg) {
539 my $next = $self->_order_by_to_dq($member, $dir, $from);
541 $inner->{from} = $next if $inner;
542 $inner = $Order_Inner || $next;
544 $Order_Inner = $inner;
546 } elsif (ref($arg) eq 'REF' and ref($$arg) eq 'ARRAY') {
547 $dq->{by} = $self->_literal_to_dq($$arg);
548 } elsif (ref($arg) eq 'SCALAR') {
550 # < mst> right, but if it doesn't match that, it goes "ok, right, not sure,
551 # totally leaving this untouched as a literal"
552 # < mst> so I -think- it's relatively robust
553 # < ribasushi> right, it's relatively safe then
554 # < ribasushi> is this regex centralized?
555 # < mst> it only exists in _order_by_to_dq in SQL::Abstract::Converter
556 # < mst> it only exists because you were kind enough to support new
557 # dbihacks crack combined with old literal order_by crack
558 # < ribasushi> heh :)
560 if (my ($ident, $dir) = $$arg =~ /^(\w+)(?:\s+(desc|asc))?$/i) {
561 $dq->{by} = $self->_ident_to_dq($ident);
562 $dq->{reverse} = 1 if $dir and lc($dir) eq 'desc';
564 $dq->{by} = $self->_literal_to_dq($$arg);
566 } elsif (ref($arg) eq 'HASH') {
567 my ($key, $val, @rest) = %$arg;
571 if (@rest or not $key =~ /^-(desc|asc)/i) {
572 die "hash passed to _order_by must have exactly one key (-desc or -asc)";
575 return $self->_order_by_to_dq($val, $dir, $from);
577 die "Can't handle $arg in _order_by_to_dq";
583 my ($self, $from) = @_;
584 if (ref($from) eq 'ARRAY') {
585 die "Empty FROM list" unless my @f = @$from;
586 my $dq = $self->_table_to_dq(shift @f);
587 while (my $x = shift @f) {
590 $self->_table_to_dq($x),
594 } elsif (ref($from) eq 'SCALAR' or (ref($from) eq 'REF')) {
595 $self->_literal_to_dq($$from);
597 $self->_ident_to_dq($from);
603 #my ($self, $col, @vals) = @_;
605 #LDNOTE : changed original implementation below because it did not make
606 # sense when bindtype eq 'columns' and @vals > 1.
607 # return $self->{bindtype} eq 'columns' ? [ $col, @vals ] : @vals;
609 # called often - tighten code
610 return $_[0]->bind_meta
611 ? map {[$_[1], $_]} @_[2 .. $#_]
616 # Dies if any element of @bind is not in [colname => value] format
617 # if bindtype is 'columns'.
618 sub _assert_bindval_matches_bindtype {
619 # my ($self, @bind) = @_;
621 if ($self->bind_meta) {
623 if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
624 die "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
630 # Fix SQL case, if so requested
632 return $_[0]->lower_case ? $_[1] : uc($_[1]);