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