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