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