lib/SQL/Abstract/Converter.pm

   1 package SQL::Abstract::Converter;
   2
   3 use Carp ();
   4 use List::Util ();
   5 use Scalar::Util ();
   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
   9 );
  10 use Data::Query::ExprHelpers;
  11 use Moo;
  12 use namespace::clean;
  13
  14 has renderer_will_quote => (
  15   is => 'ro'
  16 );
  17
  18 has lower_case => (
  19   is => 'ro'
  20 );
  21
  22 has default_logic => (
  23   is => 'ro', coerce => sub { uc($_[0]) }, default => sub { 'OR' }
  24 );
  25
  26 has bind_meta => (
  27   is => 'ro', default => sub { 1 }
  28 );
  29
  30 has cmp => (is => 'ro', default => sub { '=' });
  31
  32 has sqltrue => (is => 'ro', default => sub { '1=1' });
  33 has sqlfalse => (is => 'ro', default => sub { '0=1' });
  34
  35 has special_ops => (is => 'ro', default => sub { [] });
  36
  37 # XXX documented but I don't current fail any tests not using it
  38 has unary_ops => (is => 'ro', default => sub { [] });
  39
  40 has injection_guard => (
  41   is => 'ro',
  42   default => sub {
  43     qr/
  44       \;
  45         |
  46       ^ \s* go \s
  47     /xmi;
  48   }
  49 );
  50
  51 has identifier_sep => (
  52   is => 'ro', default => sub { '.' },
  53 );
  54
  55 has always_quote => (is => 'ro', default => sub { 1 });
  56
  57 has convert => (is => 'ro');
  58
  59 has array_datatypes => (is => 'ro');
  60
  61 sub _literal_to_dq {
  62   my ($self, $literal) = @_;
  63   my @bind;
  64   ($literal, @bind) = @$literal if ref($literal) eq 'ARRAY';
  65   Literal('SQL', $literal, [ $self->_bind_to_dq(@bind) ]);
  66 }
  67
  68 sub _bind_to_dq {
  69   my ($self, @bind) = @_;
  70   return unless @bind;
  71   $self->bind_meta
  72     ? do {
  73         $self->_assert_bindval_matches_bindtype(@bind);
  74         map perl_scalar_value(reverse @$_), @bind
  75       }
  76     : map perl_scalar_value($_), @bind
  77 }
  78
  79 sub _value_to_dq {
  80   my ($self, $value) = @_;
  81   $self->_maybe_convert_dq(perl_scalar_value($value, our $Cur_Col_Meta));
  82 }
  83
  84 sub _ident_to_dq {
  85   my ($self, $ident) = @_;
  86   $self->_assert_pass_injection_guard($ident)
  87     unless $self->renderer_will_quote;
  88   $self->_maybe_convert_dq(Identifier(split /\Q${\$self->identifier_sep}/, $ident));
  89 }
  90
  91 sub _maybe_convert_dq {
  92   my ($self, $dq) = @_;
  93   if (my $c = $self->{where_convert}) {
  94     Operator({ 'SQL.Naive' => 'apply' }, [
  95         { type => DQ_IDENTIFIER, elements => [ $self->_sqlcase($c) ] },
  96         $dq
  97       ]
  98     );
  99   } else {
 100     $dq;
 101   }
 102 }
 103
 104 sub _op_to_dq {
 105   my ($self, $op, @args) = @_;
 106   $self->_assert_pass_injection_guard($op);
 107   Operator({ 'SQL.Naive' => $op }, \@args);
 108 }
 109
 110 sub _assert_pass_injection_guard {
 111   if ($_[1] =~ $_[0]->{injection_guard}) {
 112     my $class = ref $_[0];
 113     die "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the "
 114      . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own "
 115      . "{injection_guard} attribute to ${class}->new()"
 116   }
 117 }
 118
 119 sub _insert_to_dq {
 120   my ($self, $table, $data, $options) = @_;
 121   my (@names, @values);
 122   if (ref($data) eq 'HASH') {
 123     @names = sort keys %$data;
 124     foreach my $k (@names) {
 125       local our $Cur_Col_Meta = $k;
 126       push @values, $self->_mutation_rhs_to_dq($data->{$k});
 127     }
 128   } elsif (ref($data) eq 'ARRAY') {
 129     local our $Cur_Col_Meta;
 130     @values = map $self->_mutation_rhs_to_dq($_), @$data;
 131   } else {
 132     die "Not handled yet";
 133   }
 134   my $returning;
 135   if (my $r_source = $options->{returning}) {
 136     $returning = [
 137       map +(ref($_) ? $self->_expr_to_dq($_) : $self->_ident_to_dq($_)),
 138         (ref($r_source) eq 'ARRAY' ? @$r_source : $r_source),
 139     ];
 140   }
 141   Insert(
 142     (@names ? ([ map $self->_ident_to_dq($_), @names ]) : undef),
 143     [ \@values ],
 144     $self->_table_to_dq($table),
 145     ($returning ? ($returning) : undef),
 146   );
 147 }
 148
 149 sub _mutation_rhs_to_dq {
 150   my ($self, $v) = @_;
 151   if (ref($v) eq 'ARRAY') {
 152     if ($self->{array_datatypes}) {
 153       return $self->_value_to_dq($v);
 154     }
 155     $v = \do { my $x = $v };
 156   }
 157   if (ref($v) eq 'HASH') {
 158     my ($op, $arg, @rest) = %$v;
 159
 160     die 'Operator calls in update/insert must be in the form { -op => $arg }'
 161       if (@rest or not $op =~ /^\-(.+)/);
 162   }
 163   return $self->_expr_to_dq($v);
 164 }
 165
 166 sub _update_to_dq {
 167   my ($self, $table, $data, $where) = @_;
 168
 169   die "Unsupported data type specified to \$sql->update"
 170     unless ref $data eq 'HASH';
 171
 172   my @set;
 173
 174   foreach my $k (sort keys %$data) {
 175     my $v = $data->{$k};
 176     local our $Cur_Col_Meta = $k;
 177     push @set, [ $self->_ident_to_dq($k), $self->_mutation_rhs_to_dq($v) ];
 178   }
 179
 180   Update(
 181     \@set,
 182     $self->_where_to_dq($where),
 183     $self->_table_to_dq($table),
 184   );
 185 }
 186
 187 sub _source_to_dq {
 188   my ($self, $table, undef, $where) = @_;
 189
 190   my $source_dq = $self->_table_to_dq($table);
 191
 192   if (my $where_dq = $self->_where_to_dq($where)) {
 193     $source_dq = Where($where_dq, $source_dq);
 194   }
 195
 196   $source_dq;
 197 }
 198
 199 sub _select_to_dq {
 200   my $self = shift;
 201   my ($table, $fields, $where, $order) = @_;
 202
 203   my $source_dq = $self->_source_to_dq(@_);
 204
 205   my $ordered_dq = do {
 206     if ($order) {
 207       $self->_order_by_to_dq($order, undef, $source_dq);
 208     } else {
 209       $source_dq
 210     }
 211   };
 212
 213   return $self->_select_select_to_dq($fields, $ordered_dq);
 214 }
 215
 216 sub _select_select_to_dq {
 217   my ($self, $fields, $from_dq) = @_;
 218
 219   $fields ||= '*';
 220
 221   Select(
 222     $self->_select_field_list_to_dq($fields),
 223     $from_dq,
 224   );
 225 }
 226
 227 sub _select_field_list_to_dq {
 228   my ($self, $fields) = @_;
 229   [ map $self->_select_field_to_dq($_),
 230       ref($fields) eq 'ARRAY' ? @$fields : $fields ];
 231 }
 232
 233 sub _select_field_to_dq {
 234   my ($self, $field) = @_;
 235   if (my $ref = ref($field)) {
 236     if ($ref eq 'REF' and ref($$field) eq 'HASH') {
 237       return $$field;
 238     } else {
 239       return $self->_literal_to_dq($$field);
 240     }
 241   }
 242   return $self->_ident_to_dq($field)
 243 }
 244
 245 sub _delete_to_dq {
 246   my ($self, $table, $where) = @_;
 247   Delete(
 248     $self->_where_to_dq($where),
 249     $self->_table_to_dq($table),
 250   );
 251 }
 252
 253 sub _where_to_dq {
 254   my ($self, $where, $logic) = @_;
 255
 256   return undef unless defined($where);
 257
 258   # if we're given a simple string assume it's a literal
 259   return $self->_literal_to_dq($where) if !ref($where);
 260
 261   # turn the convert misfeature on - only used in WHERE clauses
 262   local $self->{where_convert} = $self->convert;
 263
 264   return $self->_expr_to_dq($where, $logic);
 265 }
 266
 267 sub _expr_to_dq {
 268   my ($self, $where, $logic) = @_;
 269
 270   if (ref($where) eq 'ARRAY') {
 271     return $self->_expr_to_dq_ARRAYREF($where, $logic);
 272   } elsif (ref($where) eq 'HASH') {
 273     return $self->_expr_to_dq_HASHREF($where, $logic);
 274   } elsif (
 275     ref($where) eq 'SCALAR'
 276     or (ref($where) eq 'REF' and ref($$where) eq 'ARRAY')
 277   ) {
 278     return $self->_literal_to_dq($$where);
 279   } elsif (ref($where) eq 'REF' and ref($$where) eq 'HASH') {
 280     return $$where;
 281   } elsif (!ref($where) or Scalar::Util::blessed($where)) {
 282     return $self->_value_to_dq($where);
 283   }
 284   die "Can't handle $where";
 285 }
 286
 287 sub _expr_to_dq_ARRAYREF {
 288   my ($self, $where, $logic) = @_;
 289
 290   $logic = uc($logic || $self->default_logic || 'OR');
 291   $logic eq 'AND' or $logic eq 'OR' or die "unknown logic: $logic";
 292
 293   return unless @$where;
 294
 295   my ($first, @rest) = @$where;
 296
 297   return $self->_expr_to_dq($first) unless @rest;
 298
 299   my $first_dq = do {
 300     if (!ref($first)) {
 301       $self->_where_hashpair_to_dq($first => shift(@rest));
 302     } else {
 303       $self->_expr_to_dq($first);
 304     }
 305   };
 306
 307   return $self->_expr_to_dq_ARRAYREF(\@rest, $logic) unless $first_dq;
 308
 309   $self->_op_to_dq(
 310     $logic, $first_dq, $self->_expr_to_dq_ARRAYREF(\@rest, $logic)
 311   );
 312 }
 313
 314 sub _expr_to_dq_HASHREF {
 315   my ($self, $where, $logic) = @_;
 316
 317   $logic = uc($logic) if $logic;
 318
 319   my @dq = map {
 320     $self->_where_hashpair_to_dq($_ => $where->{$_}, $logic)
 321   } sort keys %$where;
 322
 323   return $dq[0] unless @dq > 1;
 324
 325   my $final = pop(@dq);
 326
 327   foreach my $dq (reverse @dq) {
 328     $final = $self->_op_to_dq($logic||'AND', $dq, $final);
 329   }
 330
 331   return $final;
 332 }
 333
 334 sub _where_to_dq_SCALAR {
 335   shift->_value_to_dq(@_);
 336 }
 337
 338 sub _apply_to_dq {
 339   my ($self, $op, $v) = @_;
 340   my @args = map $self->_expr_to_dq($_), (ref($v) eq 'ARRAY' ? @$v : $v);
 341
 342   # Ok. Welcome to stupid compat code land. An SQLA expr that would in the
 343   # absence of this piece of crazy render to:
 344   #
 345   #   A( B( C( x ) ) )
 346   #
 347   # such as
 348   #
 349   #   { -a => { -b => { -c => $x } } }
 350   #
 351   # actually needs to render to:
 352   #
 353   #   A( B( C x ) )
 354   #
 355   # because SQL sucks, and databases are hateful, and SQLA is Just That DWIM.
 356   #
 357   # However, we don't want to catch 'A(x)' and turn it into 'A x'
 358   #
 359   # So the way we deal with this is to go through all our arguments, and
 360   # then if the argument is -also- an apply, i.e. at least 'B', we check
 361   # its arguments - and if there's only one of them, and that isn't an apply,
 362   # then we convert to the bareword form. The end result should be:
 363   #
 364   # A( x )                   -> A( x )
 365   # A( B( x ) )              -> A( B x )
 366   # A( B( C( x ) ) )         -> A( B( C x ) )
 367   # A( B( x + y ) )          -> A( B( x + y ) )
 368   # A( B( x, y ) )           -> A( B( x, y ) )
 369   #
 370   # If this turns out not to be quite right, please add additional tests
 371   # to either 01generate.t or 02where.t *and* update this comment.
 372
 373   foreach my $arg (@args) {
 374     if (
 375       $arg->{type} eq DQ_OPERATOR and $arg->{operator}{'SQL.Naive'} eq 'apply'
 376       and @{$arg->{args}} == 2 and $arg->{args}[1]{type} ne DQ_OPERATOR
 377     ) {
 378       $arg->{operator}{'SQL.Naive'} = (shift @{$arg->{args}})->{elements}->[0];
 379     }
 380   }
 381   $self->_assert_pass_injection_guard($op);
 382   return $self->_op_to_dq(
 383     apply => $self->_ident_to_dq($op), @args
 384   );
 385 }
 386
 387 sub _where_hashpair_to_dq {
 388   my ($self, $k, $v, $logic) = @_;
 389
 390   if ($k =~ /^-(.*)/s) {
 391     my $op = uc($1);
 392     if ($op eq 'AND' or $op eq 'OR') {
 393       return $self->_expr_to_dq($v, $op);
 394     } elsif ($op eq 'NEST') {
 395       return $self->_expr_to_dq($v);
 396     } elsif ($op eq 'NOT') {
 397       return $self->_op_to_dq(NOT => $self->_expr_to_dq($v));
 398     } elsif ($op eq 'BOOL') {
 399       return ref($v) ? $self->_expr_to_dq($v) : $self->_ident_to_dq($v);
 400     } elsif ($op eq 'NOT_BOOL') {
 401       return $self->_op_to_dq(
 402         NOT => ref($v) ? $self->_expr_to_dq($v) : $self->_ident_to_dq($v)
 403       );
 404     } elsif ($op eq 'IDENT') {
 405       return $self->_ident_to_dq($v);
 406     } elsif ($op eq 'VALUE') {
 407       return $self->_value_to_dq($v);
 408     } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+/) {
 409       die "Use of [and|or|nest]_N modifiers is no longer supported";
 410     } else {
 411       return $self->_apply_to_dq($op, $v);
 412     }
 413   } else {
 414     local our $Cur_Col_Meta = $k;
 415     if (ref($v) eq 'ARRAY') {
 416       if (!@$v) {
 417         return $self->_literal_to_dq($self->{sqlfalse});
 418       } elsif (defined($v->[0]) && $v->[0] =~ /-(and|or)/i) {
 419         return $self->_expr_to_dq_ARRAYREF([
 420           map +{ $k => $_ }, @{$v}[1..$#$v]
 421         ], uc($1));
 422       }
 423       return $self->_expr_to_dq_ARRAYREF([
 424         map +{ $k => $_ }, @$v
 425       ], $logic);
 426     } elsif (ref($v) eq 'SCALAR' or (ref($v) eq 'REF' and ref($$v) eq 'ARRAY')) {
 427       return Literal('SQL', [ $self->_ident_to_dq($k), $self->_literal_to_dq($$v) ]);
 428     }
 429     my ($op, $rhs) = do {
 430       if (ref($v) eq 'HASH') {
 431         if (keys %$v > 1) {
 432           return $self->_expr_to_dq_ARRAYREF([
 433             map +{ $k => { $_ => $v->{$_} } }, sort keys %$v
 434           ], $logic||'AND');
 435         }
 436         my ($op, $value) = %$v;
 437         s/^-//, s/_/ /g for $op;
 438         if ($op =~ /^(and|or)$/i) {
 439           return $self->_expr_to_dq({ $k => $value }, $op);
 440         } elsif (
 441           my $special_op = List::Util::first {$op =~ $_->{regex}}
 442                              @{$self->{special_ops}}
 443         ) {
 444           return $self->_literal_to_dq(
 445             [ $special_op->{handler}->($k, $op, $value) ]
 446           );;
 447         } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+$/i) {
 448           die "Use of [and|or|nest]_N modifiers is no longer supported";
 449         }
 450         (uc($op), $value);
 451       } else {
 452         ($self->{cmp}, $v);
 453       }
 454     };
 455     if ($op eq 'BETWEEN' or $op eq 'IN' or $op eq 'NOT IN' or $op eq 'NOT BETWEEN') {
 456       if (ref($rhs) ne 'ARRAY') {
 457         if ($op =~ /IN$/) {
 458           # have to add parens if none present because -in => \"SELECT ..."
 459           # got documented. mst hates everything.
 460           if (ref($rhs) eq 'SCALAR') {
 461             my $x = $$rhs;
 462             1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
 463             $rhs = \$x;
 464           } else {
 465             my ($x, @rest) = @{$$rhs};
 466             1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
 467             $rhs = \[ $x, @rest ];
 468           }
 469         }
 470         return $self->_op_to_dq(
 471           $op, $self->_ident_to_dq($k), $self->_literal_to_dq($$rhs)
 472         );
 473       }
 474       return $self->_literal_to_dq($self->{sqlfalse}) unless @$rhs;
 475       return $self->_op_to_dq(
 476         $op, $self->_ident_to_dq($k), map $self->_expr_to_dq($_), @$rhs
 477       )
 478     } elsif ($op =~ s/^NOT (?!LIKE)//) {
 479       return $self->_where_hashpair_to_dq(-not => { $k => { $op => $rhs } });
 480     } elsif ($op eq 'IDENT') {
 481       return $self->_op_to_dq(
 482         $self->{cmp}, $self->_ident_to_dq($k), $self->_ident_to_dq($rhs)
 483       );
 484     } elsif ($op eq 'VALUE') {
 485       return $self->_op_to_dq(
 486         $self->{cmp}, $self->_ident_to_dq($k), $self->_value_to_dq($rhs)
 487       );
 488     } elsif (!defined($rhs)) {
 489       my $null_op = do {
 490         if ($op eq '=' or $op eq 'LIKE') {
 491           'IS NULL'
 492         } elsif ($op eq '!=') {
 493           'IS NOT NULL'
 494         } else {
 495           die "Can't do undef -> NULL transform for operator ${op}";
 496         }
 497       };
 498       return $self->_op_to_dq($null_op, $self->_ident_to_dq($k));
 499     }
 500     if (ref($rhs) eq 'ARRAY') {
 501       if (!@$rhs) {
 502         return $self->_literal_to_dq(
 503           $op eq '!=' ? $self->{sqltrue} : $self->{sqlfalse}
 504         );
 505       } elsif (defined($rhs->[0]) and $rhs->[0] =~ /^-(and|or)$/i) {
 506         return $self->_expr_to_dq_ARRAYREF([
 507           map +{ $k => { $op => $_ } }, @{$rhs}[1..$#$rhs]
 508         ], uc($1));
 509       } elsif ($op =~ /^-(?:AND|OR|NEST)_?\d+/) {
 510         die "Use of [and|or|nest]_N modifiers is no longer supported";
 511       }
 512       return $self->_expr_to_dq_ARRAYREF([
 513         map +{ $k => { $op => $_ } }, @$rhs
 514       ]);
 515     }
 516     return $self->_op_to_dq(
 517       $op, $self->_ident_to_dq($k), $self->_expr_to_dq($rhs)
 518     );
 519   }
 520 }
 521
 522 sub _order_by_to_dq {
 523   my ($self, $arg, $dir, $from) = @_;
 524
 525   return unless $arg;
 526
 527   my $dq = Order(
 528     undef,
 529     (defined($dir) ? (!!($dir =~ /desc/i)) : undef),
 530     ($from ? ($from) : undef),
 531   );
 532
 533   if (!ref($arg)) {
 534     $dq->{by} = $self->_ident_to_dq($arg);
 535   } elsif (ref($arg) eq 'ARRAY') {
 536     return unless @$arg;
 537     local our $Order_Inner unless our $Order_Recursing;
 538     local $Order_Recursing = 1;
 539     my ($outer, $inner);
 540     foreach my $member (@$arg) {
 541       local $Order_Inner;
 542       my $next = $self->_order_by_to_dq($member, $dir, $from);
 543       $outer ||= $next;
 544       $inner->{from} = $next if $inner;
 545       $inner = $Order_Inner || $next;
 546     }
 547     $Order_Inner = $inner;
 548     return $outer;
 549   } elsif (ref($arg) eq 'REF' and ref($$arg) eq 'ARRAY') {
 550     $dq->{by} = $self->_literal_to_dq($$arg);
 551   } elsif (ref($arg) eq 'SCALAR') {
 552
 553     # < mst> right, but if it doesn't match that, it goes "ok, right, not sure,
 554     #        totally leaving this untouched as a literal"
 555     # < mst> so I -think- it's relatively robust
 556     # < ribasushi> right, it's relatively safe then
 557     # < ribasushi> is this regex centralized?
 558     # < mst> it only exists in _order_by_to_dq in SQL::Abstract::Converter
 559     # < mst> it only exists because you were kind enough to support new
 560     #        dbihacks crack combined with old literal order_by crack
 561     # < ribasushi> heh :)
 562
 563     if (my ($ident, $dir) = $$arg =~ /^(\w+)(?:\s+(desc|asc))?$/i) {
 564       $dq->{by} = $self->_ident_to_dq($ident);
 565       $dq->{reverse} = 1 if $dir and lc($dir) eq 'desc';
 566     } else {
 567       $dq->{by} = $self->_literal_to_dq($$arg);
 568     }
 569   } elsif (ref($arg) eq 'HASH') {
 570     my ($key, $val, @rest) = %$arg;
 571
 572     return unless $key;
 573
 574     if (@rest or not $key =~ /^-(desc|asc)/i) {
 575       die "hash passed to _order_by must have exactly one key (-desc or -asc)";
 576     }
 577     my $dir = uc $1;
 578     return $self->_order_by_to_dq($val, $dir, $from);
 579   } else {
 580     die "Can't handle $arg in _order_by_to_dq";
 581   }
 582   return $dq;
 583 }
 584
 585 sub _table_to_dq {
 586   my ($self, $from) = @_;
 587   if (ref($from) eq 'ARRAY') {
 588     die "Empty FROM list" unless my @f = @$from;
 589     my $dq = $self->_table_to_dq(shift @f);
 590     while (my $x = shift @f) {
 591       $dq = Join(
 592         $dq,
 593         $self->_table_to_dq($x),
 594       );
 595     }
 596     $dq;
 597   } elsif (ref($from) eq 'SCALAR' or (ref($from) eq 'REF')) {
 598     $self->_literal_to_dq($$from);
 599   } else {
 600     $self->_ident_to_dq($from);
 601   }
 602 }
 603
 604 # And bindtype
 605 sub _bindtype (@) {
 606   #my ($self, $col, @vals) = @_;
 607
 608   #LDNOTE : changed original implementation below because it did not make
 609   # sense when bindtype eq 'columns' and @vals > 1.
 610 #  return $self->{bindtype} eq 'columns' ? [ $col, @vals ] : @vals;
 611
 612   # called often - tighten code
 613   return $_[0]->bind_meta
 614     ? map {[$_[1], $_]} @_[2 .. $#_]
 615     : @_[2 .. $#_]
 616   ;
 617 }
 618
 619 # Dies if any element of @bind is not in [colname => value] format
 620 # if bindtype is 'columns'.
 621 sub _assert_bindval_matches_bindtype {
 622 #  my ($self, @bind) = @_;
 623   my $self = shift;
 624   if ($self->bind_meta) {
 625     for (@_) {
 626       if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
 627         die "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
 628       }
 629     }
 630   }
 631 }
 632
 633 # Fix SQL case, if so requested
 634 sub _sqlcase {
 635   return $_[0]->lower_case ? $_[1] : uc($_[1]);
 636 }
 637
 638 1;