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