1 package SQL::Abstract::Converter;
6 use Data::Query::Constants qw(
7 DQ_IDENTIFIER DQ_OPERATOR DQ_VALUE DQ_LITERAL DQ_JOIN DQ_SELECT DQ_ORDER
8 DQ_WHERE DQ_DELETE DQ_UPDATE DQ_INSERT
10 use Data::Query::ExprHelpers qw(perl_scalar_value);
13 has renderer_will_quote => (
21 has default_logic => (
22 is => 'ro', coerce => sub { uc($_[0]) }, default => sub { 'OR' }
26 is => 'ro', default => sub { 1 }
29 has cmp => (is => 'ro', default => sub { '=' });
31 has sqltrue => (is => 'ro', default => sub { '1=1' });
32 has sqlfalse => (is => 'ro', default => sub { '0=1' });
34 has special_ops => (is => 'ro', default => sub { [] });
36 # XXX documented but I don't current fail any tests not using it
37 has unary_ops => (is => 'ro', default => sub { [] });
39 has injection_guard => (
50 has identifier_sep => (
51 is => 'ro', default => sub { '.' },
54 has always_quote => (is => 'ro', default => sub { 1 });
56 has convert => (is => 'ro');
58 has array_datatypes => (is => 'ro');
61 my ($self, $literal) = @_;
63 ($literal, @bind) = @$literal if ref($literal) eq 'ARRAY';
68 (@bind ? (values => [ $self->_bind_to_dq(@bind) ]) : ()),
73 my ($self, @bind) = @_;
77 $self->_assert_bindval_matches_bindtype(@bind);
78 map perl_scalar_value(reverse @$_), @bind
80 : map perl_scalar_value($_), @bind
84 my ($self, $value) = @_;
85 $self->_maybe_convert_dq(perl_scalar_value($value, our $Cur_Col_Meta));
89 my ($self, $ident) = @_;
90 $self->_assert_pass_injection_guard($ident)
91 unless $self->renderer_will_quote;
92 $self->_maybe_convert_dq({
93 type => DQ_IDENTIFIER,
94 elements => [ split /\Q${\$self->identifier_sep}/, $ident ],
98 sub _maybe_convert_dq {
100 if (my $c = $self->{where_convert}) {
103 operator => { 'SQL.Naive' => 'apply' },
105 { type => DQ_IDENTIFIER, elements => [ $self->_sqlcase($c) ] },
115 my ($self, $op, @args) = @_;
116 $self->_assert_pass_injection_guard($op);
119 operator => { 'SQL.Naive' => $op },
124 sub _assert_pass_injection_guard {
125 if ($_[1] =~ $_[0]->{injection_guard}) {
126 my $class = ref $_[0];
127 die "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the "
128 . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own "
129 . "{injection_guard} attribute to ${class}->new()"
134 my ($self, $table, $data, $options) = @_;
135 my (@names, @values);
136 if (ref($data) eq 'HASH') {
137 @names = sort keys %$data;
138 foreach my $k (@names) {
139 local our $Cur_Col_Meta = $k;
140 push @values, $self->_mutation_rhs_to_dq($data->{$k});
142 } elsif (ref($data) eq 'ARRAY') {
143 local our $Cur_Col_Meta;
144 @values = map $self->_mutation_rhs_to_dq($_), @$data;
146 die "Not handled yet";
149 if (my $r_source = $options->{returning}) {
151 map +(ref($_) ? $self->_expr_to_dq($_) : $self->_ident_to_dq($_)),
152 (ref($r_source) eq 'ARRAY' ? @$r_source : $r_source),
157 target => $self->_table_to_dq($table),
158 (@names ? (names => [ map $self->_ident_to_dq($_), @names ]) : ()),
159 values => [ \@values ],
160 ($returning ? (returning => $returning) : ()),
164 sub _mutation_rhs_to_dq {
166 if (ref($v) eq 'ARRAY') {
167 if ($self->{array_datatypes}) {
168 return $self->_value_to_dq($v);
170 $v = \do { my $x = $v };
172 if (ref($v) eq 'HASH') {
173 my ($op, $arg, @rest) = %$v;
175 die 'Operator calls in update/insert must be in the form { -op => $arg }'
176 if (@rest or not $op =~ /^\-(.+)/);
178 return $self->_expr_to_dq($v);
182 my ($self, $table, $data, $where) = @_;
184 die "Unsupported data type specified to \$sql->update"
185 unless ref $data eq 'HASH';
189 foreach my $k (sort keys %$data) {
191 local our $Cur_Col_Meta = $k;
192 push @set, [ $self->_ident_to_dq($k), $self->_mutation_rhs_to_dq($v) ];
197 target => $self->_table_to_dq($table),
199 where => $self->_where_to_dq($where),
204 my ($self, $table, undef, $where) = @_;
206 my $source_dq = $self->_table_to_dq($table);
208 if (my $where_dq = $self->_where_to_dq($where)) {
221 my ($table, $fields, $where, $order) = @_;
223 my $source_dq = $self->_source_to_dq(@_);
225 my $ordered_dq = do {
227 $self->_order_by_to_dq($order, undef, $source_dq);
233 return $self->_select_select_to_dq($fields, $ordered_dq);
236 sub _select_select_to_dq {
237 my ($self, $fields, $from_dq) = @_;
243 select => $self->_select_field_list_to_dq($fields),
248 sub _select_field_list_to_dq {
249 my ($self, $fields) = @_;
250 [ map $self->_select_field_to_dq($_),
251 ref($fields) eq 'ARRAY' ? @$fields : $fields ];
254 sub _select_field_to_dq {
255 my ($self, $field) = @_;
256 if (my $ref = ref($field)) {
257 if ($ref eq 'REF' and ref($$field) eq 'HASH') {
260 return $self->_literal_to_dq($$field);
263 return $self->_ident_to_dq($field)
267 my ($self, $table, $where) = @_;
270 target => $self->_table_to_dq($table),
271 where => $self->_where_to_dq($where),
276 my ($self, $where, $logic) = @_;
278 return undef unless defined($where);
280 # turn the convert misfeature on - only used in WHERE clauses
281 local $self->{where_convert} = $self->convert;
283 return $self->_expr_to_dq($where, $logic);
287 my ($self, $where, $logic) = @_;
289 if (ref($where) eq 'ARRAY') {
290 return $self->_expr_to_dq_ARRAYREF($where, $logic);
291 } elsif (ref($where) eq 'HASH') {
292 return $self->_expr_to_dq_HASHREF($where, $logic);
294 ref($where) eq 'SCALAR'
295 or (ref($where) eq 'REF' and ref($$where) eq 'ARRAY')
297 return $self->_literal_to_dq($$where);
298 } elsif (!ref($where) or Scalar::Util::blessed($where)) {
299 return $self->_value_to_dq($where);
301 die "Can't handle $where";
304 sub _expr_to_dq_ARRAYREF {
305 my ($self, $where, $logic) = @_;
307 $logic = uc($logic || $self->default_logic || 'OR');
308 $logic eq 'AND' or $logic eq 'OR' or die "unknown logic: $logic";
310 return unless @$where;
312 my ($first, @rest) = @$where;
314 return $self->_expr_to_dq($first) unless @rest;
318 $self->_where_hashpair_to_dq($first => shift(@rest));
320 $self->_expr_to_dq($first);
324 return $self->_expr_to_dq_ARRAYREF(\@rest, $logic) unless $first_dq;
327 $logic, $first_dq, $self->_expr_to_dq_ARRAYREF(\@rest, $logic)
331 sub _expr_to_dq_HASHREF {
332 my ($self, $where, $logic) = @_;
334 $logic = uc($logic) if $logic;
337 $self->_where_hashpair_to_dq($_ => $where->{$_}, $logic)
340 return $dq[0] unless @dq > 1;
342 my $final = pop(@dq);
344 foreach my $dq (reverse @dq) {
345 $final = $self->_op_to_dq($logic||'AND', $dq, $final);
351 sub _where_to_dq_SCALAR {
352 shift->_value_to_dq(@_);
356 my ($self, $op, $v) = @_;
357 my @args = map $self->_expr_to_dq($_), (ref($v) eq 'ARRAY' ? @$v : $v);
359 # Ok. Welcome to stupid compat code land. An SQLA expr that would in the
360 # absence of this piece of crazy render to:
366 # { -a => { -b => { -c => $x } } }
368 # actually needs to render to:
372 # because SQL sucks, and databases are hateful, and SQLA is Just That DWIM.
374 # However, we don't want to catch 'A(x)' and turn it into 'A x'
376 # So the way we deal with this is to go through all our arguments, and
377 # then if the argument is -also- an apply, i.e. at least 'B', we check
378 # its arguments - and if there's only one of them, and that isn't an apply,
379 # then we convert to the bareword form. The end result should be:
382 # A( B( x ) ) -> A( B x )
383 # A( B( C( x ) ) ) -> A( B( C x ) )
384 # A( B( x + y ) ) -> A( B( x + y ) )
385 # A( B( x, y ) ) -> A( B( x, y ) )
387 # If this turns out not to be quite right, please add additional tests
388 # to either 01generate.t or 02where.t *and* update this comment.
390 foreach my $arg (@args) {
392 $arg->{type} eq DQ_OPERATOR and $arg->{operator}{'SQL.Naive'} eq 'apply'
393 and @{$arg->{args}} == 2 and $arg->{args}[1]{type} ne DQ_OPERATOR
395 $arg->{operator}{'SQL.Naive'} = (shift @{$arg->{args}})->{elements}->[0];
398 $self->_assert_pass_injection_guard($op);
399 return $self->_op_to_dq(
400 apply => $self->_ident_to_dq($op), @args
404 sub _where_hashpair_to_dq {
405 my ($self, $k, $v, $logic) = @_;
407 if ($k =~ /^-(.*)/s) {
409 if ($op eq 'AND' or $op eq 'OR') {
410 return $self->_expr_to_dq($v, $op);
411 } elsif ($op eq 'NEST') {
412 return $self->_expr_to_dq($v);
413 } elsif ($op eq 'NOT') {
414 return $self->_op_to_dq(NOT => $self->_expr_to_dq($v));
415 } elsif ($op eq 'BOOL') {
416 return ref($v) ? $self->_expr_to_dq($v) : $self->_ident_to_dq($v);
417 } elsif ($op eq 'NOT_BOOL') {
418 return $self->_op_to_dq(
419 NOT => ref($v) ? $self->_expr_to_dq($v) : $self->_ident_to_dq($v)
421 } elsif ($op eq 'IDENT') {
422 return $self->_ident_to_dq($v);
423 } elsif ($op eq 'VALUE') {
424 return $self->_value_to_dq($v);
425 } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+/) {
426 die "Use of [and|or|nest]_N modifiers is no longer supported";
428 return $self->_apply_to_dq($op, $v);
431 local our $Cur_Col_Meta = $k;
432 if (ref($v) eq 'ARRAY') {
434 return $self->_literal_to_dq($self->{sqlfalse});
435 } elsif (defined($v->[0]) && $v->[0] =~ /-(and|or)/i) {
436 return $self->_expr_to_dq_ARRAYREF([
437 map +{ $k => $_ }, @{$v}[1..$#$v]
440 return $self->_expr_to_dq_ARRAYREF([
441 map +{ $k => $_ }, @$v
443 } elsif (ref($v) eq 'SCALAR' or (ref($v) eq 'REF' and ref($$v) eq 'ARRAY')) {
447 parts => [ $self->_ident_to_dq($k), $self->_literal_to_dq($$v) ]
450 my ($op, $rhs) = do {
451 if (ref($v) eq 'HASH') {
453 return $self->_expr_to_dq_ARRAYREF([
454 map +{ $k => { $_ => $v->{$_} } }, sort keys %$v
457 my ($op, $value) = %$v;
458 s/^-//, s/_/ /g for $op;
459 if ($op =~ /^(and|or)$/i) {
460 return $self->_expr_to_dq({ $k => $value }, $op);
462 my $special_op = List::Util::first {$op =~ $_->{regex}}
463 @{$self->{special_ops}}
465 return $self->_literal_to_dq(
466 [ $special_op->{handler}->($k, $op, $value) ]
468 } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+$/i) {
469 die "Use of [and|or|nest]_N modifiers is no longer supported";
476 if ($op eq 'BETWEEN' or $op eq 'IN' or $op eq 'NOT IN' or $op eq 'NOT BETWEEN') {
477 if (ref($rhs) ne 'ARRAY') {
479 # have to add parens if none present because -in => \"SELECT ..."
480 # got documented. mst hates everything.
481 if (ref($rhs) eq 'SCALAR') {
483 1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
486 my ($x, @rest) = @{$$rhs};
487 1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
488 $rhs = \[ $x, @rest ];
491 return $self->_op_to_dq(
492 $op, $self->_ident_to_dq($k), $self->_literal_to_dq($$rhs)
495 return $self->_literal_to_dq($self->{sqlfalse}) unless @$rhs;
496 return $self->_op_to_dq(
497 $op, $self->_ident_to_dq($k), map $self->_expr_to_dq($_), @$rhs
499 } elsif ($op =~ s/^NOT (?!LIKE)//) {
500 return $self->_where_hashpair_to_dq(-not => { $k => { $op => $rhs } });
501 } elsif ($op eq 'IDENT') {
502 return $self->_op_to_dq(
503 $self->{cmp}, $self->_ident_to_dq($k), $self->_ident_to_dq($rhs)
505 } elsif ($op eq 'VALUE') {
506 return $self->_op_to_dq(
507 $self->{cmp}, $self->_ident_to_dq($k), $self->_value_to_dq($rhs)
509 } elsif (!defined($rhs)) {
511 if ($op eq '=' or $op eq 'LIKE') {
513 } elsif ($op eq '!=') {
516 die "Can't do undef -> NULL transform for operator ${op}";
519 return $self->_op_to_dq($null_op, $self->_ident_to_dq($k));
521 if (ref($rhs) eq 'ARRAY') {
523 return $self->_literal_to_dq(
524 $op eq '!=' ? $self->{sqltrue} : $self->{sqlfalse}
526 } elsif (defined($rhs->[0]) and $rhs->[0] =~ /^-(and|or)$/i) {
527 return $self->_expr_to_dq_ARRAYREF([
528 map +{ $k => { $op => $_ } }, @{$rhs}[1..$#$rhs]
530 } elsif ($op =~ /^-(?:AND|OR|NEST)_?\d+/) {
531 die "Use of [and|or|nest]_N modifiers is no longer supported";
533 return $self->_expr_to_dq_ARRAYREF([
534 map +{ $k => { $op => $_ } }, @$rhs
537 return $self->_op_to_dq(
538 $op, $self->_ident_to_dq($k), $self->_expr_to_dq($rhs)
543 sub _order_by_to_dq {
544 my ($self, $arg, $dir, $from) = @_;
550 ($dir ? (direction => $dir) : ()),
551 ($from ? (from => $from) : ()),
555 $dq->{by} = $self->_ident_to_dq($arg);
556 } elsif (ref($arg) eq 'ARRAY') {
558 local our $Order_Inner unless our $Order_Recursing;
559 local $Order_Recursing = 1;
561 foreach my $member (@$arg) {
563 my $next = $self->_order_by_to_dq($member, $dir, $from);
565 $inner->{from} = $next if $inner;
566 $inner = $Order_Inner || $next;
568 $Order_Inner = $inner;
570 } elsif (ref($arg) eq 'REF' and ref($$arg) eq 'ARRAY') {
571 $dq->{by} = $self->_literal_to_dq($$arg);
572 } elsif (ref($arg) eq 'SCALAR') {
573 $dq->{by} = $self->_literal_to_dq($$arg);
574 } elsif (ref($arg) eq 'HASH') {
575 my ($key, $val, @rest) = %$arg;
579 if (@rest or not $key =~ /^-(desc|asc)/i) {
580 die "hash passed to _order_by must have exactly one key (-desc or -asc)";
583 return $self->_order_by_to_dq($val, $dir, $from);
585 die "Can't handle $arg in _order_by_to_dq";
591 my ($self, $from) = @_;
592 if (ref($from) eq 'ARRAY') {
593 die "Empty FROM list" unless my @f = @$from;
594 my $dq = $self->_table_to_dq(shift @f);
595 while (my $x = shift @f) {
598 join => [ $dq, $self->_table_to_dq($x) ]
602 } elsif (ref($from) eq 'SCALAR' or (ref($from) eq 'REF')) {
603 $self->_literal_to_dq($$from);
605 $self->_ident_to_dq($from);
611 #my ($self, $col, @vals) = @_;
613 #LDNOTE : changed original implementation below because it did not make
614 # sense when bindtype eq 'columns' and @vals > 1.
615 # return $self->{bindtype} eq 'columns' ? [ $col, @vals ] : @vals;
617 # called often - tighten code
618 return $_[0]->bind_meta
619 ? map {[$_[1], $_]} @_[2 .. $#_]
624 # Dies if any element of @bind is not in [colname => value] format
625 # if bindtype is 'columns'.
626 sub _assert_bindval_matches_bindtype {
627 # my ($self, @bind) = @_;
629 if ($self->bind_meta) {
631 if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
632 die "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
638 # Fix SQL case, if so requested
640 return $_[0]->lower_case ? $_[1] : uc($_[1]);