lib/SQL/Abstract.pm

   1 package SQL::Abstract; # see doc at end of file
   2
   3 use strict;
   4 use warnings;
   5 use Module::Runtime ();
   6 use Carp ();
   7 use List::Util ();
   8 use Scalar::Util ();
   9
  10 use Exporter 'import';
  11 our @EXPORT_OK = qw(is_plain_value is_literal_value);
  12
  13 BEGIN {
  14   if ($] < 5.009_005) {
  15     require MRO::Compat;
  16   }
  17   else {
  18     require mro;
  19   }
  20
  21   *SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION = $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}
  22     ? sub () { 0 }
  23     : sub () { 1 }
  24   ;
  25 }
  26
  27 #======================================================================
  28 # GLOBALS
  29 #======================================================================
  30
  31 our $VERSION  = '1.86';
  32
  33 # This would confuse some packagers
  34 $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
  35
  36 our $AUTOLOAD;
  37
  38 # special operators (-in, -between). May be extended/overridden by user.
  39 # See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation
  40 my @BUILTIN_SPECIAL_OPS = (
  41   {regex => qr/^ (?: not \s )? between $/ix, handler => sub { die "NOPE" }},
  42   {regex => qr/^ is (?: \s+ not )?     $/ix, handler => sub { die "NOPE" }},
  43   {regex => qr/^ (?: not \s )? in      $/ix, handler => sub { die "NOPE" }},
  44   {regex => qr/^ ident                 $/ix, handler => sub { die "NOPE" }},
  45   {regex => qr/^ value                 $/ix, handler => sub { die "NOPE" }},
  46 );
  47
  48 #======================================================================
  49 # DEBUGGING AND ERROR REPORTING
  50 #======================================================================
  51
  52 sub _debug {
  53   return unless $_[0]->{debug}; shift; # a little faster
  54   my $func = (caller(1))[3];
  55   warn "[$func] ", @_, "\n";
  56 }
  57
  58 sub belch (@) {
  59   my($func) = (caller(1))[3];
  60   Carp::carp "[$func] Warning: ", @_;
  61 }
  62
  63 sub puke (@) {
  64   my($func) = (caller(1))[3];
  65   Carp::croak "[$func] Fatal: ", @_;
  66 }
  67
  68 sub is_literal_value ($) {
  69     ref $_[0] eq 'SCALAR'                                     ? [ ${$_[0]} ]
  70   : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' )        ? [ @${ $_[0] } ]
  71   : undef;
  72 }
  73
  74 sub is_undef_value ($) {
  75   !defined($_[0])
  76   or (
  77     ref($_[0]) eq 'HASH'
  78     and exists $_[0]->{-value}
  79     and not defined $_[0]->{-value}
  80   );
  81 }
  82
  83 # FIXME XSify - this can be done so much more efficiently
  84 sub is_plain_value ($) {
  85   no strict 'refs';
  86     ! length ref $_[0]                                        ? \($_[0])
  87   : (
  88     ref $_[0] eq 'HASH' and keys %{$_[0]} == 1
  89       and
  90     exists $_[0]->{-value}
  91   )                                                           ? \($_[0]->{-value})
  92   : (
  93       # reuse @_ for even moar speedz
  94       defined ( $_[1] = Scalar::Util::blessed $_[0] )
  95         and
  96       # deliberately not using Devel::OverloadInfo - the checks we are
  97       # intersted in are much more limited than the fullblown thing, and
  98       # this is a very hot piece of code
  99       (
 100         # simply using ->can('(""') can leave behind stub methods that
 101         # break actually using the overload later (see L<perldiag/Stub
 102         # found while resolving method "%s" overloading "%s" in package
 103         # "%s"> and the source of overload::mycan())
 104         #
 105         # either has stringification which DBI SHOULD prefer out of the box
 106         grep { *{ (qq[${_}::(""]) }{CODE} } @{ $_[2] = mro::get_linear_isa( $_[1] ) }
 107           or
 108         # has nummification or boolification, AND fallback is *not* disabled
 109         (
 110           SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION
 111             and
 112           (
 113             grep { *{"${_}::(0+"}{CODE} } @{$_[2]}
 114               or
 115             grep { *{"${_}::(bool"}{CODE} } @{$_[2]}
 116           )
 117             and
 118           (
 119             # no fallback specified at all
 120             ! ( ($_[3]) = grep { *{"${_}::()"}{CODE} } @{$_[2]} )
 121               or
 122             # fallback explicitly undef
 123             ! defined ${"$_[3]::()"}
 124               or
 125             # explicitly true
 126             !! ${"$_[3]::()"}
 127           )
 128         )
 129       )
 130     )                                                          ? \($_[0])
 131   : undef;
 132 }
 133
 134
 135
 136 #======================================================================
 137 # NEW
 138 #======================================================================
 139
 140 our %Defaults = (
 141   expand => {
 142     not => '_expand_not',
 143     bool => '_expand_bool',
 144     and => '_expand_op_andor',
 145     or => '_expand_op_andor',
 146     nest => '_expand_nest',
 147     bind => '_expand_bind',
 148     in => '_expand_in',
 149     not_in => '_expand_in',
 150     row => '_expand_row',
 151     between => '_expand_between',
 152     not_between => '_expand_between',
 153     op => '_expand_op',
 154     (map +($_ => '_expand_op_is'), ('is', 'is_not')),
 155     ident => '_expand_ident',
 156     value => '_expand_value',
 157     func => '_expand_func',
 158   },
 159   expand_op => {
 160     'between' => '_expand_between',
 161     'not_between' => '_expand_between',
 162     'in' => '_expand_in',
 163     'not_in' => '_expand_in',
 164     'nest' => '_expand_nest',
 165     (map +($_ => '_expand_op_andor'), ('and', 'or')),
 166     (map +($_ => '_expand_op_is'), ('is', 'is_not')),
 167     'ident' => '_expand_ident',
 168     'value' => '_expand_value',
 169   },
 170   render => {
 171     (map +($_, "_render_$_"), qw(op func bind ident literal row)),
 172   },
 173   render_op => {
 174     (map +($_ => '_render_op_between'), 'between', 'not_between'),
 175     (map +($_ => '_render_op_in'), 'in', 'not_in'),
 176     (map +($_ => '_render_unop_postfix'),
 177       'is_null', 'is_not_null', 'asc', 'desc',
 178     ),
 179     (not => '_render_unop_paren'),
 180     (map +($_ => '_render_op_andor'), qw(and or)),
 181     ',' => '_render_op_multop',
 182   },
 183   clauses_of => {
 184     delete => [ qw(target where returning) ],
 185   },
 186   expand_clause => {
 187     'delete.from' => '_expand_delete_clause_target',
 188   },
 189   render_clause => {
 190     'delete.target' => '_render_delete_clause_target',
 191   },
 192 );
 193
 194 foreach my $stmt (keys %{$Defaults{clauses_of}}) {
 195   $Defaults{expand}{$stmt} = '_expand_statement';
 196   $Defaults{render}{$stmt} = '_render_statement';
 197   foreach my $clause (@{$Defaults{clauses_of}{$stmt}}) {
 198     $Defaults{expand_clause}{"${stmt}.${clause}"}
 199       = "_expand_${stmt}_clause_${clause}";
 200   }
 201 }
 202
 203 sub new {
 204   my $self = shift;
 205   my $class = ref($self) || $self;
 206   my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
 207
 208   # choose our case by keeping an option around
 209   delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
 210
 211   # default logic for interpreting arrayrefs
 212   $opt{logic} = $opt{logic} ? uc $opt{logic} : 'OR';
 213
 214   # how to return bind vars
 215   $opt{bindtype} ||= 'normal';
 216
 217   # default comparison is "=", but can be overridden
 218   $opt{cmp} ||= '=';
 219
 220   # try to recognize which are the 'equality' and 'inequality' ops
 221   # (temporary quickfix (in 2007), should go through a more seasoned API)
 222   $opt{equality_op}   = qr/^( \Q$opt{cmp}\E | \= )$/ix;
 223   $opt{inequality_op} = qr/^( != | <> )$/ix;
 224
 225   $opt{like_op}       = qr/^ (is_)?r?like $/xi;
 226   $opt{not_like_op}   = qr/^ (is_)?not_r?like $/xi;
 227
 228   # SQL booleans
 229   $opt{sqltrue}  ||= '1=1';
 230   $opt{sqlfalse} ||= '0=1';
 231
 232   # special operators
 233   $opt{special_ops} ||= [];
 234
 235   if ($class->isa('DBIx::Class::SQLMaker')) {
 236     $opt{warn_once_on_nest} = 1;
 237     $opt{disable_old_special_ops} = 1;
 238   }
 239
 240   # unary operators
 241   $opt{unary_ops} ||= [];
 242
 243   # rudimentary sanity-check for user supplied bits treated as functions/operators
 244   # If a purported  function matches this regular expression, an exception is thrown.
 245   # Literal SQL is *NOT* subject to this check, only functions (and column names
 246   # when quoting is not in effect)
 247
 248   # FIXME
 249   # need to guard against ()'s in column names too, but this will break tons of
 250   # hacks... ideas anyone?
 251   $opt{injection_guard} ||= qr/
 252     \;
 253       |
 254     ^ \s* go \s
 255   /xmi;
 256
 257   $opt{expand_unary} = {};
 258
 259   foreach my $name (sort keys %Defaults) {
 260     $opt{$name} = { %{$Defaults{$name}} };
 261   }
 262
 263   if ($opt{lazy_join_sql_parts}) {
 264     my $mod = Module::Runtime::use_module('SQL::Abstract::Parts');
 265     $opt{join_sql_parts} ||= sub { $mod->new(@_) };
 266   }
 267
 268   $opt{join_sql_parts} ||= sub { join $_[0], @_[1..$#_] };
 269
 270   return bless \%opt, $class;
 271 }
 272
 273 sub sqltrue { +{ -literal => [ $_[0]->{sqltrue} ] } }
 274 sub sqlfalse { +{ -literal => [ $_[0]->{sqlfalse} ] } }
 275
 276 sub _assert_pass_injection_guard {
 277   if ($_[1] =~ $_[0]->{injection_guard}) {
 278     my $class = ref $_[0];
 279     puke "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the "
 280      . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own "
 281      . "{injection_guard} attribute to ${class}->new()"
 282   }
 283 }
 284
 285
 286 #======================================================================
 287 # INSERT methods
 288 #======================================================================
 289
 290 sub insert {
 291   my $self    = shift;
 292   my $table   = $self->_table(shift);
 293   my $data    = shift || return;
 294   my $options = shift;
 295
 296   my $fields;
 297
 298   my ($f_aqt, $v_aqt) = $self->_expand_insert_values($data);
 299
 300   my @parts = ([ $self->_sqlcase('insert into').' '.$table ]);
 301   push @parts, $self->render_aqt($f_aqt) if $f_aqt;
 302   push @parts, [ $self->_sqlcase('values') ], $self->render_aqt($v_aqt);
 303
 304   if ($options->{returning}) {
 305     push @parts, [ $self->_insert_returning($options) ];
 306   }
 307
 308   my ($sql, @bind) = @{ $self->join_query_parts(' ', @parts) };
 309   return wantarray ? ($sql, @bind) : $sql;
 310 }
 311
 312 sub _expand_insert_values {
 313   my ($self, $data) = @_;
 314   if (is_literal_value($data)) {
 315     (undef, $self->expand_expr($data));
 316   } else {
 317     my ($fields, $values) = (
 318       ref($data) eq 'HASH' ?
 319         ([ sort keys %$data ], [ @{$data}{sort keys %$data} ])
 320         : ([], $data)
 321     );
 322
 323     # no names (arrayref) means can't generate bindtype
 324     !($fields) && $self->{bindtype} eq 'columns'
 325       && belch "can't do 'columns' bindtype when called with arrayref";
 326
 327     +(
 328       (@$fields
 329         ? $self->expand_expr({ -row => $fields }, -ident)
 330         : undef
 331       ),
 332       +{ -row => [
 333         map {
 334          local our $Cur_Col_Meta = $fields->[$_];
 335          $self->_expand_insert_value($values->[$_])
 336          } 0..$#$values
 337       ] },
 338     );
 339   }
 340 }
 341
 342 # So that subclasses can override INSERT ... RETURNING separately from
 343 # UPDATE and DELETE (e.g. DBIx::Class::SQLMaker::Oracle does this)
 344 sub _insert_returning { shift->_returning(@_) }
 345
 346 sub _returning {
 347   my ($self, $options) = @_;
 348
 349   my $f = $options->{returning};
 350
 351   my ($sql, @bind) = @{ $self->render_aqt(
 352     $self->_expand_maybe_list_expr($f, -ident)
 353   ) };
 354   return ($self->_sqlcase(' returning ').$sql, @bind);
 355 }
 356
 357 sub _expand_insert_value {
 358   my ($self, $v) = @_;
 359
 360   my $k = our $Cur_Col_Meta;
 361
 362   if (ref($v) eq 'ARRAY') {
 363     if ($self->{array_datatypes}) {
 364       return +{ -bind => [ $k, $v ] };
 365     }
 366     my ($sql, @bind) = @$v;
 367     $self->_assert_bindval_matches_bindtype(@bind);
 368     return +{ -literal => $v };
 369   }
 370   if (ref($v) eq 'HASH') {
 371     if (grep !/^-/, keys %$v) {
 372       belch "HASH ref as bind value in insert is not supported";
 373       return +{ -bind => [ $k, $v ] };
 374     }
 375   }
 376   if (!defined($v)) {
 377     return +{ -bind => [ $k, undef ] };
 378   }
 379   return $self->expand_expr($v);
 380 }
 381
 382
 383
 384 #======================================================================
 385 # UPDATE methods
 386 #======================================================================
 387
 388
 389 sub update {
 390   my $self    = shift;
 391   my $table   = $self->_table(shift);
 392   my $data    = shift || return;
 393   my $where   = shift;
 394   my $options = shift;
 395
 396   # first build the 'SET' part of the sql statement
 397   puke "Unsupported data type specified to \$sql->update"
 398     unless ref $data eq 'HASH';
 399
 400   my ($sql, @all_bind) = $self->_update_set_values($data);
 401   $sql = $self->_sqlcase('update ') . $table . $self->_sqlcase(' set ')
 402           . $sql;
 403
 404   if ($where) {
 405     my($where_sql, @where_bind) = $self->where($where);
 406     $sql .= $where_sql;
 407     push @all_bind, @where_bind;
 408   }
 409
 410   if ($options->{returning}) {
 411     my ($returning_sql, @returning_bind) = $self->_update_returning($options);
 412     $sql .= $returning_sql;
 413     push @all_bind, @returning_bind;
 414   }
 415
 416   return wantarray ? ($sql, @all_bind) : $sql;
 417 }
 418
 419 sub _update_set_values {
 420   my ($self, $data) = @_;
 421
 422   return @{ $self->render_aqt(
 423     $self->_expand_update_set_values(undef, $data),
 424   ) };
 425 }
 426
 427 sub _expand_update_set_values {
 428   my ($self, undef, $data) = @_;
 429   $self->_expand_maybe_list_expr( [
 430     map {
 431       my ($k, $set) = @$_;
 432       $set = { -bind => $_ } unless defined $set;
 433       +{ -op => [ '=', { -ident => $k }, $set ] };
 434     }
 435     map {
 436       my $k = $_;
 437       my $v = $data->{$k};
 438       (ref($v) eq 'ARRAY'
 439         ? ($self->{array_datatypes}
 440             ? [ $k, +{ -bind => [ $k, $v ] } ]
 441             : [ $k, +{ -literal => $v } ])
 442         : do {
 443             local our $Cur_Col_Meta = $k;
 444             [ $k, $self->_expand_expr($v) ]
 445           }
 446       );
 447     } sort keys %$data
 448   ] );
 449 }
 450
 451 # So that subclasses can override UPDATE ... RETURNING separately from
 452 # INSERT and DELETE
 453 sub _update_returning { shift->_returning(@_) }
 454
 455
 456
 457 #======================================================================
 458 # SELECT
 459 #======================================================================
 460
 461
 462 sub select {
 463   my $self   = shift;
 464   my $table  = $self->_table(shift);
 465   my $fields = shift || '*';
 466   my $where  = shift;
 467   my $order  = shift;
 468
 469   my ($fields_sql, @bind) = $self->_select_fields($fields);
 470
 471   my ($where_sql, @where_bind) = $self->where($where, $order);
 472   push @bind, @where_bind;
 473
 474   my $sql = join(' ', $self->_sqlcase('select'), $fields_sql,
 475                       $self->_sqlcase('from'),   $table)
 476           . $where_sql;
 477
 478   return wantarray ? ($sql, @bind) : $sql;
 479 }
 480
 481 sub _select_fields {
 482   my ($self, $fields) = @_;
 483   return $fields unless ref($fields);
 484   return @{ $self->render_aqt(
 485     $self->_expand_maybe_list_expr($fields, '-ident')
 486   ) };
 487 }
 488
 489 #======================================================================
 490 # DELETE
 491 #======================================================================
 492
 493 sub delete {
 494   my ($self, $table, $where, $options) = @_;
 495
 496   my $stmt = do {
 497     if (ref($table) eq 'HASH') {
 498       $table;
 499     } else {
 500       my %clauses = (target => $table, where => $where, %{$options||{}});
 501       \%clauses;
 502     }
 503   };
 504   my @rendered = $self->render_statement({ -delete => $stmt });
 505   return wantarray ? @rendered : $rendered[0];
 506 }
 507
 508 # So that subclasses can override DELETE ... RETURNING separately from
 509 # INSERT and UPDATE
 510 sub _delete_returning { shift->_returning(@_) }
 511
 512 sub _expand_delete_clause_target {
 513   +(target => $_[0]->_expand_maybe_list_expr($_[2], -ident));
 514 }
 515
 516 sub _expand_delete_clause_where { +(where => $_[0]->expand_expr($_[2])); }
 517
 518 sub _expand_delete_clause_returning {
 519   +(returning => $_[0]->_expand_maybe_list_expr($_[2], -ident));
 520 }
 521
 522 sub _render_delete_clause_target {
 523    my ($self, undef, $from) = @_;
 524    $self->join_query_parts(' ', $self->format_keyword('delete from'), $from);
 525 }
 526
 527 #======================================================================
 528 # WHERE: entry point
 529 #======================================================================
 530
 531
 532
 533 # Finally, a separate routine just to handle WHERE clauses
 534 sub where {
 535   my ($self, $where, $order) = @_;
 536
 537   local $self->{convert_where} = $self->{convert};
 538
 539   # where ?
 540   my ($sql, @bind) = defined($where)
 541    ? $self->_recurse_where($where)
 542    : (undef);
 543   $sql = (defined $sql and length $sql) ? $self->_sqlcase(' where ') . "( $sql )" : '';
 544
 545   # order by?
 546   if ($order) {
 547     my ($order_sql, @order_bind) = $self->_order_by($order);
 548     $sql .= $order_sql;
 549     push @bind, @order_bind;
 550   }
 551
 552   return wantarray ? ($sql, @bind) : $sql;
 553 }
 554
 555 { our $Default_Scalar_To = -value }
 556
 557 sub expand_expr {
 558   my ($self, $expr, $default_scalar_to) = @_;
 559   local our $Default_Scalar_To = $default_scalar_to if $default_scalar_to;
 560   $self->_expand_expr($expr);
 561 }
 562
 563 sub render_aqt {
 564   my ($self, $aqt, $top_level) = @_;
 565   my ($k, $v, @rest) = %$aqt;
 566   die "No" if @rest;
 567   die "Not a node type: $k" unless $k =~ s/^-//;
 568   if (my $meth = $self->{render}{$k}) {
 569     local our $Render_Top_Level = $top_level;
 570     return $self->$meth($k, $v);
 571   }
 572   die "notreached: $k";
 573 }
 574
 575 sub render_expr {
 576   my ($self, $expr, $default_scalar_to) = @_;
 577   return @{ $self->render_aqt(
 578     $self->expand_expr($expr, $default_scalar_to)
 579   ) };
 580 }
 581
 582 sub render_statement {
 583   my ($self, $expr, $default_scalar_to) = @_;
 584   @{$self->render_aqt(
 585     $self->expand_expr($expr, $default_scalar_to), 1
 586   )};
 587 }
 588
 589 sub _expand_statement {
 590   my ($self, $type, $args) = @_;
 591   my $ec = $self->{expand_clause};
 592   if ($args->{_}) {
 593     $args = { %$args };
 594     $args->{$type} = delete $args->{_}
 595   }
 596   return +{ "-${type}" => +{
 597     map {
 598       my $val = $args->{$_};
 599       if (defined($val) and my $exp = $ec->{"${type}.$_"}) {
 600         if ((my (@exp) = $self->$exp($_ => $val)) == 1) {
 601           ($_ => $exp[0])
 602         } else {
 603           @exp
 604         }
 605       } else {
 606         ($_ => $self->expand_expr($val))
 607       }
 608     } sort keys %$args
 609   } };
 610 }
 611
 612 sub _render_statement {
 613   my ($self, $type, $args) = @_;
 614   my @parts;
 615   foreach my $clause (@{$self->{clauses_of}{$type}}) {
 616     next unless my $clause_expr = $args->{$clause};
 617     my $part = do {
 618       if (my $rdr = $self->{render_clause}{"${type}.${clause}"}) {
 619         $self->$rdr($clause, $clause_expr);
 620       } else {
 621         my $r = $self->render_aqt($clause_expr, 1);
 622         next unless defined $r->[0] and length $r->[0];
 623         $self->join_query_parts(' ',
 624           $self->format_keyword($clause),
 625           $r
 626         );
 627       }
 628     };
 629     push @parts, $part;
 630   }
 631   my $q = $self->join_query_parts(' ', @parts);
 632   return $self->join_query_parts('',
 633     (our $Render_Top_Level ? $q : ('(', $q, ')'))
 634   );
 635 }
 636
 637 sub _normalize_op {
 638   my ($self, $raw) = @_;
 639   my $op = lc $raw;
 640   return $op if grep $_->{$op}, @{$self}{qw(is_op expand_op render_op)};
 641   s/^-(?=.)//, s/\s+/_/g for $op;
 642   $op;
 643 }
 644
 645 sub _expand_expr {
 646   my ($self, $expr) = @_;
 647   our $Expand_Depth ||= 0; local $Expand_Depth = $Expand_Depth + 1;
 648   return undef unless defined($expr);
 649   if (ref($expr) eq 'HASH') {
 650     return undef unless my $kc = keys %$expr;
 651     if ($kc > 1) {
 652       return $self->_expand_op_andor(and => $expr);
 653     }
 654     my ($key, $value) = %$expr;
 655     if ($key =~ /^-/ and $key =~ s/ [_\s]? \d+ $//x ) {
 656       belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
 657           . "You probably wanted ...-and => [ $key => COND1, $key => COND2 ... ]";
 658     }
 659     return $self->_expand_hashpair($key, $value);
 660   }
 661   if (ref($expr) eq 'ARRAY') {
 662     return $self->_expand_op_andor(lc($self->{logic}), $expr);
 663   }
 664   if (my $literal = is_literal_value($expr)) {
 665     return +{ -literal => $literal };
 666   }
 667   if (!ref($expr) or Scalar::Util::blessed($expr)) {
 668     return $self->_expand_scalar($expr);
 669   }
 670   die "notreached";
 671 }
 672
 673 sub _expand_hashpair {
 674   my ($self, $k, $v) = @_;
 675   unless (defined($k) and length($k)) {
 676     if (defined($k) and my $literal = is_literal_value($v)) {
 677       belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead';
 678       return { -literal => $literal };
 679     }
 680     puke "Supplying an empty left hand side argument is not supported";
 681   }
 682   if ($k =~ /^-./) {
 683     return $self->_expand_hashpair_op($k, $v);
 684   } elsif ($k =~ /^[^\w]/i) {
 685     my ($lhs, @rhs) = ref($v) eq 'ARRAY' ? @$v : $v;
 686     return $self->_expand_op(
 687       -op, [ $k, $self->expand_expr($lhs, -ident), @rhs ]
 688     );
 689   }
 690   return $self->_expand_hashpair_ident($k, $v);
 691 }
 692
 693 sub _expand_hashpair_ident {
 694   my ($self, $k, $v) = @_;
 695
 696   local our $Cur_Col_Meta = $k;
 697
 698   # hash with multiple or no elements is andor
 699
 700   if (ref($v) eq 'HASH' and keys %$v != 1) {
 701     return $self->_expand_op_andor(and => $v, $k);
 702   }
 703
 704   # undef needs to be re-sent with cmp to achieve IS/IS NOT NULL
 705
 706   if (is_undef_value($v)) {
 707     return $self->_expand_hashpair_cmp($k => undef);
 708   }
 709
 710   # scalars and objects get expanded as whatever requested or values
 711
 712   if (!ref($v) or Scalar::Util::blessed($v)) {
 713     return $self->_expand_hashpair_scalar($k, $v);
 714   }
 715
 716   # single key hashref is a hashtriple
 717
 718   if (ref($v) eq 'HASH') {
 719     return $self->_expand_hashtriple($k, %$v);
 720   }
 721
 722   # arrayref needs re-engineering over the elements
 723
 724   if (ref($v) eq 'ARRAY') {
 725     return $self->sqlfalse unless @$v;
 726     $self->_debug("ARRAY($k) means distribute over elements");
 727     my $logic = lc(
 728       $v->[0] =~ /^-(and|or)$/i
 729         ? (shift(@{$v = [ @$v ]}), $1)
 730         : lc($self->{logic} || 'OR')
 731     );
 732     return $self->_expand_op_andor(
 733       $logic => $v, $k
 734     );
 735   }
 736
 737   if (my $literal = is_literal_value($v)) {
 738     unless (length $k) {
 739       belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead';
 740       return \$literal;
 741     }
 742     my ($sql, @bind) = @$literal;
 743     if ($self->{bindtype} eq 'columns') {
 744       for (@bind) {
 745         $self->_assert_bindval_matches_bindtype($_);
 746       }
 747     }
 748     return +{ -literal => [ $self->_quote($k).' '.$sql, @bind ] };
 749   }
 750   die "notreached";
 751 }
 752
 753 sub _expand_scalar {
 754   my ($self, $expr) = @_;
 755
 756   return $self->_expand_expr({ (our $Default_Scalar_To) => $expr });
 757 }
 758
 759 sub _expand_hashpair_scalar {
 760   my ($self, $k, $v) = @_;
 761
 762   return $self->_expand_hashpair_cmp(
 763     $k, $self->_expand_scalar($v),
 764   );
 765 }
 766
 767 sub _expand_hashpair_op {
 768   my ($self, $k, $v) = @_;
 769
 770   $self->_assert_pass_injection_guard($k =~ /\A-(.*)\Z/s);
 771
 772   my $op = $self->_normalize_op($k);
 773
 774   { # Old SQLA compat
 775
 776     my $op = join(' ', split '_', $op);
 777
 778     # the old special op system requires illegality for top-level use
 779
 780     if (
 781       (our $Expand_Depth) == 1
 782       and (
 783         List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}
 784         or (
 785           $self->{disable_old_special_ops}
 786           and List::Util::first { $op =~ $_->{regex} } @BUILTIN_SPECIAL_OPS
 787         )
 788       )
 789     ) {
 790       puke "Illegal use of top-level '-$op'"
 791     }
 792   }
 793
 794   if (my $exp = $self->{expand}{$op}) {
 795     return $self->$exp($op, $v);
 796   }
 797
 798   # Ops prefixed with -not_ get converted
 799
 800   if (my ($rest) = $op =~/^not_(.*)$/) {
 801     return +{ -op => [
 802       'not',
 803       $self->_expand_expr({ "-${rest}", $v })
 804     ] };
 805   }
 806
 807   { # Old SQLA compat
 808
 809     # the old unary op system means we should touch nothing and let it work
 810
 811     my $op = join(' ', split '_', $op);
 812
 813     if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
 814       return { -op => [ $op, $v ] };
 815     }
 816   }
 817
 818   # an explicit node type is currently assumed to be expanded (this is almost
 819   # certainly wrong and there should be expansion anyway)
 820
 821   if ($self->{render}{$op}) {
 822     return { $k => $v };
 823   }
 824
 825   my $type = $self->{unknown_unop_always_func} ? -func : -op;
 826
 827   { # Old SQLA compat
 828
 829     if (
 830       ref($v) eq 'HASH'
 831       and keys %$v == 1
 832       and (keys %$v)[0] =~ /^-/
 833     ) {
 834       $type = (
 835         (List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}})
 836           ? -op
 837           : -func
 838       )
 839     }
 840   }
 841
 842   return +{ $type => [
 843     $op,
 844     ($type eq -func and ref($v) eq 'ARRAY')
 845       ? map $self->_expand_expr($_), @$v
 846       : $self->_expand_expr($v)
 847   ] };
 848 }
 849
 850 sub _expand_hashpair_cmp {
 851   my ($self, $k, $v) = @_;
 852   $self->_expand_hashtriple($k, $self->{cmp}, $v);
 853 }
 854
 855 sub _expand_hashtriple {
 856   my ($self, $k, $vk, $vv) = @_;
 857
 858   my $ik = $self->_expand_expr({ -ident => $k });
 859
 860   my $op = $self->_normalize_op($vk);
 861   $self->_assert_pass_injection_guard($op);
 862
 863   if ($op =~ s/ _? \d+ $//x ) {
 864     return $self->_expand_expr($k, { $vk, $vv });
 865   }
 866   if (my $x = $self->{expand_op}{$op}) {
 867     local our $Cur_Col_Meta = $k;
 868     return $self->$x($op, $vv, $k);
 869   }
 870   { # Old SQLA compat
 871
 872     my $op = join(' ', split '_', $op);
 873
 874     if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}) {
 875       return { -op => [ $op, $ik, $vv ] };
 876     }
 877     if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
 878       return { -op => [
 879         $self->{cmp},
 880         $ik,
 881         { -op => [ $op, $vv ] }
 882       ] };
 883     }
 884   }
 885   if (ref($vv) eq 'ARRAY') {
 886     my @raw = @$vv;
 887     my $logic = (defined($raw[0]) and $raw[0] =~ /^-(and|or)$/i)
 888       ? (shift(@raw), lc $1) : 'or';
 889     my @values = map +{ $vk => $_ }, @raw;
 890     if (
 891       $op =~ $self->{inequality_op}
 892       or $op =~ $self->{not_like_op}
 893     ) {
 894       if (lc($logic) eq 'or' and @values > 1) {
 895         belch "A multi-element arrayref as an argument to the inequality op '${\uc(join ' ', split '_', $op)}' "
 896             . 'is technically equivalent to an always-true 1=1 (you probably wanted '
 897             . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)"
 898         ;
 899       }
 900     }
 901     unless (@values) {
 902       # try to DWIM on equality operators
 903       return ($self->_dwim_op_to_is($op,
 904         "Supplying an empty arrayref to '%s' is deprecated",
 905         "operator '%s' applied on an empty array (field '$k')"
 906       ) ? $self->sqlfalse : $self->sqltrue);
 907     }
 908     return $self->_expand_op_andor($logic => \@values, $k);
 909   }
 910   if (is_undef_value($vv)) {
 911     my $is = ($self->_dwim_op_to_is($op,
 912       "Supplying an undefined argument to '%s' is deprecated",
 913       "unexpected operator '%s' with undef operand",
 914     ) ? 'is' : 'is not');
 915
 916     return $self->_expand_hashpair($k => { $is, undef });
 917   }
 918   local our $Cur_Col_Meta = $k;
 919   return +{ -op => [
 920     $op,
 921     $ik,
 922     $self->_expand_expr($vv)
 923   ] };
 924 }
 925
 926 sub _dwim_op_to_is {
 927   my ($self, $raw, $empty, $fail) = @_;
 928
 929   my $op = $self->_normalize_op($raw);
 930
 931   if ($op =~ /^not$/i) {
 932     return 0;
 933   }
 934   if ($op =~ $self->{equality_op}) {
 935     return 1;
 936   }
 937   if ($op =~ $self->{like_op}) {
 938     belch(sprintf $empty, uc(join ' ', split '_', $op));
 939     return 1;
 940   }
 941   if ($op =~ $self->{inequality_op}) {
 942     return 0;
 943   }
 944   if ($op =~ $self->{not_like_op}) {
 945     belch(sprintf $empty, uc(join ' ', split '_', $op));
 946     return 0;
 947   }
 948   puke(sprintf $fail, $op);
 949 }
 950
 951 sub _expand_func {
 952   my ($self, undef, $args) = @_;
 953   my ($func, @args) = @$args;
 954   return +{ -func => [ $func, map $self->expand_expr($_), @args ] };
 955 }
 956
 957 sub _expand_ident {
 958   my ($self, undef, $body, $k) = @_;
 959   return $self->_expand_hashpair_cmp(
 960     $k, { -ident => $body }
 961   ) if defined($k);
 962   unless (defined($body) or (ref($body) and ref($body) eq 'ARRAY')) {
 963     puke "-ident requires a single plain scalar argument (a quotable identifier) or an arrayref of identifier parts";
 964   }
 965   my @parts = map split(/\Q${\($self->{name_sep}||'.')}\E/, $_),
 966                 ref($body) ? @$body : $body;
 967   return { -ident => $parts[-1] } if $self->{_dequalify_idents};
 968   unless ($self->{quote_char}) {
 969     $self->_assert_pass_injection_guard($_) for @parts;
 970   }
 971   return +{ -ident => \@parts };
 972 }
 973
 974 sub _expand_value {
 975   return $_[0]->_expand_hashpair_cmp(
 976     $_[3], { -value => $_[2] },
 977   ) if defined($_[3]);
 978   +{ -bind => [ our $Cur_Col_Meta, $_[2] ] };
 979 }
 980
 981 sub _expand_not {
 982   +{ -op => [ 'not', $_[0]->_expand_expr($_[2]) ] };
 983 }
 984
 985 sub _expand_row {
 986   my ($self, undef, $args) = @_;
 987   +{ -row => [ map $self->expand_expr($_), @$args ] };
 988 }
 989
 990 sub _expand_op {
 991   my ($self, undef, $args) = @_;
 992   my ($op, @opargs) = @$args;
 993   if (my $exp = $self->{expand_op}{$op}) {
 994     return $self->$exp($op, \@opargs);
 995   }
 996   +{ -op => [ $op, map $self->expand_expr($_), @opargs ] };
 997 }
 998
 999 sub _expand_bool {
1000   my ($self, undef, $v) = @_;
1001   if (ref($v)) {
1002     return $self->_expand_expr($v);
1003   }
1004   puke "-bool => undef not supported" unless defined($v);
1005   return $self->_expand_expr({ -ident => $v });
1006 }
1007
1008 sub _expand_op_andor {
1009   my ($self, $logop, $v, $k) = @_;
1010   if (defined $k) {
1011     $v = [ map +{ $k, $_ },
1012              (ref($v) eq 'HASH')
1013               ? (map +{ $_ => $v->{$_} }, sort keys %$v)
1014               : @$v,
1015          ];
1016   }
1017   if (ref($v) eq 'HASH') {
1018     return undef unless keys %$v;
1019     return +{ -op => [
1020       $logop,
1021       map $self->_expand_expr({ $_ => $v->{$_} }),
1022         sort keys %$v
1023     ] };
1024   }
1025   if (ref($v) eq 'ARRAY') {
1026     $logop eq 'and' or $logop eq 'or' or puke "unknown logic: $logop";
1027
1028     my @expr = grep {
1029       (ref($_) eq 'ARRAY' and @$_)
1030       or (ref($_) eq 'HASH' and %$_)
1031       or 1
1032     } @$v;
1033
1034     my @res;
1035
1036     while (my ($el) = splice @expr, 0, 1) {
1037       puke "Supplying an empty left hand side argument is not supported in array-pairs"
1038         unless defined($el) and length($el);
1039       my $elref = ref($el);
1040       if (!$elref) {
1041         local our $Expand_Depth = 0;
1042         push(@res, grep defined, $self->_expand_expr({ $el, shift(@expr) }));
1043       } elsif ($elref eq 'ARRAY') {
1044         push(@res, grep defined, $self->_expand_expr($el)) if @$el;
1045       } elsif (my $l = is_literal_value($el)) {
1046         push @res, { -literal => $l };
1047       } elsif ($elref eq 'HASH') {
1048         local our $Expand_Depth = 0;
1049         push @res, grep defined, $self->_expand_expr($el) if %$el;
1050       } else {
1051         die "notreached";
1052       }
1053     }
1054     # ???
1055     # return $res[0] if @res == 1;
1056     return { -op => [ $logop, @res ] };
1057   }
1058   die "notreached";
1059 }
1060
1061 sub _expand_op_is {
1062   my ($self, $op, $vv, $k) = @_;
1063   ($k, $vv) = @$vv unless defined $k;
1064   puke "$op can only take undef as argument"
1065     if defined($vv)
1066        and not (
1067          ref($vv) eq 'HASH'
1068          and exists($vv->{-value})
1069          and !defined($vv->{-value})
1070        );
1071   return +{ -op => [ $op.'_null', $self->expand_expr($k, -ident) ] };
1072 }
1073
1074 sub _expand_between {
1075   my ($self, $op, $vv, $k) = @_;
1076   $k = shift @{$vv = [ @$vv ]} unless defined $k;
1077   my @rhs = map $self->_expand_expr($_),
1078               ref($vv) eq 'ARRAY' ? @$vv : $vv;
1079   unless (
1080     (@rhs == 1 and ref($rhs[0]) eq 'HASH' and $rhs[0]->{-literal})
1081     or
1082     (@rhs == 2 and defined($rhs[0]) and defined($rhs[1]))
1083   ) {
1084     puke "Operator '${\uc($op)}' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref";
1085   }
1086   return +{ -op => [
1087     $op,
1088     $self->expand_expr(ref($k) ? $k : { -ident => $k }),
1089     @rhs
1090   ] }
1091 }
1092
1093 sub _expand_in {
1094   my ($self, $op, $vv, $k) = @_;
1095   $k = shift @{$vv = [ @$vv ]} unless defined $k;
1096   if (my $literal = is_literal_value($vv)) {
1097     my ($sql, @bind) = @$literal;
1098     my $opened_sql = $self->_open_outer_paren($sql);
1099     return +{ -op => [
1100       $op, $self->expand_expr($k, -ident),
1101       { -literal => [ $opened_sql, @bind ] }
1102     ] };
1103   }
1104   my $undef_err =
1105     'SQL::Abstract before v1.75 used to generate incorrect SQL when the '
1106   . "-${\uc($op)} operator was given an undef-containing list: !!!AUDIT YOUR CODE "
1107   . 'AND DATA!!! (the upcoming Data::Query-based version of SQL::Abstract '
1108   . 'will emit the logically correct SQL instead of raising this exception)'
1109   ;
1110   puke("Argument passed to the '${\uc($op)}' operator can not be undefined")
1111     if !defined($vv);
1112   my @rhs = map $self->expand_expr($_, -value),
1113               map { defined($_) ? $_: puke($undef_err) }
1114                 (ref($vv) eq 'ARRAY' ? @$vv : $vv);
1115   return $self->${\($op =~ /^not/ ? 'sqltrue' : 'sqlfalse')} unless @rhs;
1116
1117   return +{ -op => [
1118     $op,
1119     $self->expand_expr($k, -ident),
1120     @rhs
1121   ] };
1122 }
1123
1124 sub _expand_nest {
1125   my ($self, undef, $v) = @_;
1126   # DBIx::Class requires a nest warning to be emitted once but the private
1127   # method it overrode to do so no longer exists
1128   if ($self->{warn_once_on_nest}) {
1129     unless (our $Nest_Warned) {
1130       belch(
1131         "-nest in search conditions is deprecated, you most probably wanted:\n"
1132         .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
1133       );
1134       $Nest_Warned = 1;
1135     }
1136   }
1137   return $self->_expand_expr($v);
1138 }
1139
1140 sub _expand_bind {
1141   my ($self, undef, $bind) = @_;
1142   return { -bind => $bind };
1143 }
1144
1145 sub _recurse_where {
1146   my ($self, $where, $logic) = @_;
1147
1148   # Special case: top level simple string treated as literal
1149
1150   my $where_exp = (ref($where)
1151                     ? $self->_expand_expr($where, $logic)
1152                     : { -literal => [ $where ] });
1153
1154   # dispatch expanded expression
1155
1156   my ($sql, @bind) = defined($where_exp) ? @{ $self->render_aqt($where_exp) || [] } : ();
1157   # DBIx::Class used to call _recurse_where in scalar context
1158   # something else might too...
1159   if (wantarray) {
1160     return ($sql, @bind);
1161   }
1162   else {
1163     belch "Calling _recurse_where in scalar context is deprecated and will go away before 2.0";
1164     return $sql;
1165   }
1166 }
1167
1168 sub _render_ident {
1169   my ($self, undef, $ident) = @_;
1170
1171   return [ $self->_convert($self->_quote($ident)) ];
1172 }
1173
1174 sub _render_row {
1175   my ($self, undef, $values) = @_;
1176   return $self->join_query_parts('',
1177     '(',
1178     $self->_render_op(undef, [ ',', @$values ]),
1179     ')'
1180   );
1181 }
1182
1183 sub _render_func {
1184   my ($self, undef, $rest) = @_;
1185   my ($func, @args) = @$rest;
1186   return $self->join_query_parts('',
1187     $self->_sqlcase($func),
1188     $self->join_query_parts('',
1189       '(',
1190       $self->join_query_parts(', ', @args),
1191       ')'
1192     ),
1193   );
1194 }
1195
1196 sub _render_bind {
1197   my ($self, undef, $bind) = @_;
1198   return [ $self->_convert('?'), $self->_bindtype(@$bind) ];
1199 }
1200
1201 sub _render_literal {
1202   my ($self, undef, $literal) = @_;
1203   $self->_assert_bindval_matches_bindtype(@{$literal}[1..$#$literal]);
1204   return $literal;
1205 }
1206
1207 sub _render_op {
1208   my ($self, undef, $v) = @_;
1209   my ($op, @args) = @$v;
1210   if (my $r = $self->{render_op}{$op}) {
1211     return $self->$r($op, \@args);
1212   }
1213
1214   { # Old SQLA compat
1215
1216     my $op = join(' ', split '_', $op);
1217
1218     my $ss = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
1219     if ($ss and @args > 1) {
1220       puke "Special op '${op}' requires first value to be identifier"
1221         unless my ($ident) = map $_->{-ident}, grep ref($_) eq 'HASH', $args[0];
1222       my $k = join(($self->{name_sep}||'.'), @$ident);
1223       local our $Expand_Depth = 1;
1224       return [ $self->${\($ss->{handler})}($k, $op, $args[1]) ];
1225     }
1226     if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
1227       return [ $self->${\($us->{handler})}($op, $args[0]) ];
1228     }
1229     if ($ss) {
1230       return $self->_render_unop_paren($op, \@args);
1231     }
1232   }
1233   if (@args == 1) {
1234     return $self->_render_unop_prefix($op, \@args);
1235   } else {
1236     return $self->_render_op_multop($op, \@args);
1237   }
1238   die "notreached";
1239 }
1240
1241
1242 sub _render_op_between {
1243   my ($self, $op, $args) = @_;
1244   my ($left, $low, $high) = @$args;
1245   my @rh = do {
1246     if (@$args == 2) {
1247       puke "Single arg to between must be a literal"
1248         unless $low->{-literal};
1249       $low;
1250     } else {
1251       +($low, $self->format_keyword('and'), $high);
1252     }
1253   };
1254   return $self->join_query_parts(' ',
1255     '(', $left, $self->format_keyword($op), @rh, ')',
1256   );
1257 }
1258
1259 sub _render_op_in {
1260   my ($self, $op, $args) = @_;
1261   my ($lhs, @rhs) = @$args;
1262
1263   return $self->join_query_parts(' ',
1264     $lhs,
1265     $self->format_keyword($op),
1266     $self->join_query_parts(' ',
1267       '(',
1268       $self->join_query_parts(', ', @rhs),
1269       ')'
1270     ),
1271   );
1272 }
1273
1274 sub _render_op_andor {
1275   my ($self, $op, $args) = @_;
1276   return undef unless @$args;
1277   return $self->join_query_parts('', $args->[0]) if @$args == 1;
1278   my $inner = $self->_render_op_multop($op, $args);
1279   return undef unless defined($inner->[0]) and length($inner->[0]);
1280   return $self->join_query_parts(' ',
1281     '(', $inner, ')'
1282   );
1283 }
1284
1285 sub _render_op_multop {
1286   my ($self, $op, $args) = @_;
1287   my @parts = @$args;
1288   return undef unless @parts;
1289   return $self->render_aqt($parts[0]) if @parts == 1;
1290   my $join = ($op eq ','
1291                 ? ', '
1292                 :  ' '.$self->format_keyword($op).' '
1293              );
1294   return $self->join_query_parts($join, @parts);
1295 }
1296
1297 sub join_query_parts {
1298   my ($self, $join, @parts) = @_;
1299   my @final = map +(
1300     ref($_) eq 'HASH'
1301       ? $self->render_aqt($_)
1302       : ((ref($_) eq 'ARRAY') ? $_ : [ $_ ])
1303   ), @parts;
1304   return [
1305     $self->{join_sql_parts}->($join, grep defined, map $_->[0], @final),
1306     (map @{$_}[1..$#$_], @final),
1307   ];
1308 }
1309
1310 sub _render_unop_paren {
1311   my ($self, $op, $v) = @_;
1312   return $self->join_query_parts('',
1313     '(', $self->_render_unop_prefix($op, $v), ')'
1314   );
1315 }
1316
1317 sub _render_unop_prefix {
1318   my ($self, $op, $v) = @_;
1319   return $self->join_query_parts(' ',
1320     $self->_sqlcase($op), $v->[0]
1321   );
1322 }
1323
1324 sub _render_unop_postfix {
1325   my ($self, $op, $v) = @_;
1326   return $self->join_query_parts(' ',
1327     $v->[0], $self->format_keyword($op),
1328   );
1329 }
1330
1331 # Some databases (SQLite) treat col IN (1, 2) different from
1332 # col IN ( (1, 2) ). Use this to strip all outer parens while
1333 # adding them back in the corresponding method
1334 sub _open_outer_paren {
1335   my ($self, $sql) = @_;
1336
1337   while (my ($inner) = $sql =~ /^ \s* \( (.*) \) \s* $/xs) {
1338
1339     # there are closing parens inside, need the heavy duty machinery
1340     # to reevaluate the extraction starting from $sql (full reevaluation)
1341     if ($inner =~ /\)/) {
1342       require Text::Balanced;
1343
1344       my (undef, $remainder) = do {
1345         # idiotic design - writes to $@ but *DOES NOT* throw exceptions
1346         local $@;
1347         Text::Balanced::extract_bracketed($sql, '()', qr/\s*/);
1348       };
1349
1350       # the entire expression needs to be a balanced bracketed thing
1351       # (after an extract no remainder sans trailing space)
1352       last if defined $remainder and $remainder =~ /\S/;
1353     }
1354
1355     $sql = $inner;
1356   }
1357
1358   $sql;
1359 }
1360
1361
1362 #======================================================================
1363 # ORDER BY
1364 #======================================================================
1365
1366 sub _expand_order_by {
1367   my ($self, $arg) = @_;
1368
1369   return unless defined($arg) and not (ref($arg) eq 'ARRAY' and !@$arg);
1370
1371   return $self->_expand_maybe_list_expr($arg)
1372     if ref($arg) eq 'HASH' and ($arg->{-op}||[''])->[0] eq ',';
1373
1374   my $expander = sub {
1375     my ($self, $dir, $expr) = @_;
1376     my @to_expand = ref($expr) eq 'ARRAY' ? @$expr : $expr;
1377     foreach my $arg (@to_expand) {
1378       if (
1379         ref($arg) eq 'HASH'
1380         and keys %$arg > 1
1381         and grep /^-(asc|desc)$/, keys %$arg
1382       ) {
1383         puke "ordering direction hash passed to order by must have exactly one key (-asc or -desc)";
1384       }
1385     }
1386     my @exp = map +(
1387                 defined($dir) ? { -op => [ $dir =~ /^-?(.*)$/ ,=> $_ ] } : $_
1388               ),
1389                 map $self->expand_expr($_, -ident),
1390                 map ref($_) eq 'ARRAY' ? @$_ : $_, @to_expand;
1391     return undef unless @exp;
1392     return undef if @exp == 1 and not defined($exp[0]);
1393     return +{ -op => [ ',', @exp ] };
1394   };
1395
1396   local @{$self->{expand}}{qw(asc desc)} = (($expander) x 2);
1397
1398   return $self->$expander(undef, $arg);
1399 }
1400
1401 sub _order_by {
1402   my ($self, $arg) = @_;
1403
1404   return '' unless defined(my $expanded = $self->_expand_order_by($arg));
1405
1406   my ($sql, @bind) = @{ $self->render_aqt($expanded) };
1407
1408   return '' unless length($sql);
1409
1410   my $final_sql = $self->_sqlcase(' order by ').$sql;
1411
1412   return ($final_sql, @bind);
1413 }
1414
1415 # _order_by no longer needs to call this so doesn't but DBIC uses it.
1416
1417 sub _order_by_chunks {
1418   my ($self, $arg) = @_;
1419
1420   return () unless defined(my $expanded = $self->_expand_order_by($arg));
1421
1422   my @res = $self->_chunkify_order_by($expanded);
1423   (ref() ? $_->[0] : $_) .= '' for @res;
1424   return @res;
1425 }
1426
1427 sub _chunkify_order_by {
1428   my ($self, $expanded) = @_;
1429
1430   return grep length, @{ $self->render_aqt($expanded) }
1431     if $expanded->{-ident} or @{$expanded->{-literal}||[]} == 1;
1432
1433   for ($expanded) {
1434     if (ref() eq 'HASH' and $_->{-op} and $_->{-op}[0] eq ',') {
1435       my ($comma, @list) = @{$_->{-op}};
1436       return map $self->_chunkify_order_by($_), @list;
1437     }
1438     return $self->render_aqt($_);
1439   }
1440 }
1441
1442 #======================================================================
1443 # DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
1444 #======================================================================
1445
1446 sub _table  {
1447   my $self = shift;
1448   my $from = shift;
1449   $self->render_aqt(
1450     $self->_expand_maybe_list_expr($from, -ident)
1451   )->[0];
1452 }
1453
1454
1455 #======================================================================
1456 # UTILITY FUNCTIONS
1457 #======================================================================
1458
1459 sub _expand_maybe_list_expr {
1460   my ($self, $expr, $default) = @_;
1461   return { -op => [
1462     ',', map $self->expand_expr($_, $default),
1463           @{$expr->{-op}}[1..$#{$expr->{-op}}]
1464   ] } if ref($expr) eq 'HASH' and ($expr->{-op}||[''])->[0] eq ',';
1465   return +{ -op => [ ',',
1466     map $self->expand_expr($_, $default),
1467       ref($expr) eq 'ARRAY' ? @$expr : $expr
1468   ] };
1469 }
1470
1471 # highly optimized, as it's called way too often
1472 sub _quote {
1473   # my ($self, $label) = @_;
1474
1475   return '' unless defined $_[1];
1476   return ${$_[1]} if ref($_[1]) eq 'SCALAR';
1477   puke 'Identifier cannot be hashref' if ref($_[1]) eq 'HASH';
1478
1479   unless ($_[0]->{quote_char}) {
1480     if (ref($_[1]) eq 'ARRAY') {
1481       return join($_[0]->{name_sep}||'.', @{$_[1]});
1482     } else {
1483       $_[0]->_assert_pass_injection_guard($_[1]);
1484       return $_[1];
1485     }
1486   }
1487
1488   my $qref = ref $_[0]->{quote_char};
1489   my ($l, $r) =
1490       !$qref             ? ($_[0]->{quote_char}, $_[0]->{quote_char})
1491     : ($qref eq 'ARRAY') ? @{$_[0]->{quote_char}}
1492     : puke "Unsupported quote_char format: $_[0]->{quote_char}";
1493
1494   my $esc = $_[0]->{escape_char} || $r;
1495
1496   # parts containing * are naturally unquoted
1497   return join(
1498     $_[0]->{name_sep}||'',
1499     map +(
1500       $_ eq '*'
1501         ? $_
1502         : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r }
1503     ),
1504     (ref($_[1]) eq 'ARRAY'
1505       ? @{$_[1]}
1506       : (
1507           $_[0]->{name_sep}
1508             ? split (/\Q$_[0]->{name_sep}\E/, $_[1] )
1509             : $_[1]
1510         )
1511     )
1512   );
1513 }
1514
1515
1516 # Conversion, if applicable
1517 sub _convert {
1518   #my ($self, $arg) = @_;
1519   if (my $conv = $_[0]->{convert_where}) {
1520     return @{ $_[0]->join_query_parts('',
1521       $_[0]->format_keyword($conv),
1522       '(' , $_[1] , ')'
1523     ) };
1524   }
1525   return $_[1];
1526 }
1527
1528 # And bindtype
1529 sub _bindtype {
1530   #my ($self, $col, @vals) = @_;
1531   # called often - tighten code
1532   return $_[0]->{bindtype} eq 'columns'
1533     ? map {[$_[1], $_]} @_[2 .. $#_]
1534     : @_[2 .. $#_]
1535   ;
1536 }
1537
1538 # Dies if any element of @bind is not in [colname => value] format
1539 # if bindtype is 'columns'.
1540 sub _assert_bindval_matches_bindtype {
1541 #  my ($self, @bind) = @_;
1542   my $self = shift;
1543   if ($self->{bindtype} eq 'columns') {
1544     for (@_) {
1545       if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
1546         puke "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
1547       }
1548     }
1549   }
1550 }
1551
1552 sub _join_sql_clauses {
1553   my ($self, $logic, $clauses_aref, $bind_aref) = @_;
1554
1555   if (@$clauses_aref > 1) {
1556     my $join  = " " . $self->_sqlcase($logic) . " ";
1557     my $sql = '( ' . join($join, @$clauses_aref) . ' )';
1558     return ($sql, @$bind_aref);
1559   }
1560   elsif (@$clauses_aref) {
1561     return ($clauses_aref->[0], @$bind_aref); # no parentheses
1562   }
1563   else {
1564     return (); # if no SQL, ignore @$bind_aref
1565   }
1566 }
1567
1568
1569 # Fix SQL case, if so requested
1570 sub _sqlcase {
1571   # LDNOTE: if $self->{case} is true, then it contains 'lower', so we
1572   # don't touch the argument ... crooked logic, but let's not change it!
1573   return $_[0]->{case} ? $_[1] : uc($_[1]);
1574 }
1575
1576 sub format_keyword { $_[0]->_sqlcase(join ' ', split '_', $_[1]) }
1577
1578 #======================================================================
1579 # DISPATCHING FROM REFKIND
1580 #======================================================================
1581
1582 sub _refkind {
1583   my ($self, $data) = @_;
1584
1585   return 'UNDEF' unless defined $data;
1586
1587   # blessed objects are treated like scalars
1588   my $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
1589
1590   return 'SCALAR' unless $ref;
1591
1592   my $n_steps = 1;
1593   while ($ref eq 'REF') {
1594     $data = $$data;
1595     $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
1596     $n_steps++ if $ref;
1597   }
1598
1599   return ($ref||'SCALAR') . ('REF' x $n_steps);
1600 }
1601
1602 sub _try_refkind {
1603   my ($self, $data) = @_;
1604   my @try = ($self->_refkind($data));
1605   push @try, 'SCALAR_or_UNDEF' if $try[0] eq 'SCALAR' || $try[0] eq 'UNDEF';
1606   push @try, 'FALLBACK';
1607   return \@try;
1608 }
1609
1610 sub _METHOD_FOR_refkind {
1611   my ($self, $meth_prefix, $data) = @_;
1612
1613   my $method;
1614   for (@{$self->_try_refkind($data)}) {
1615     $method = $self->can($meth_prefix."_".$_)
1616       and last;
1617   }
1618
1619   return $method || puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data);
1620 }
1621
1622
1623 sub _SWITCH_refkind {
1624   my ($self, $data, $dispatch_table) = @_;
1625
1626   my $coderef;
1627   for (@{$self->_try_refkind($data)}) {
1628     $coderef = $dispatch_table->{$_}
1629       and last;
1630   }
1631
1632   puke "no dispatch entry for ".$self->_refkind($data)
1633     unless $coderef;
1634
1635   $coderef->();
1636 }
1637
1638
1639
1640
1641 #======================================================================
1642 # VALUES, GENERATE, AUTOLOAD
1643 #======================================================================
1644
1645 # LDNOTE: original code from nwiger, didn't touch code in that section
1646 # I feel the AUTOLOAD stuff should not be the default, it should
1647 # only be activated on explicit demand by user.
1648
1649 sub values {
1650     my $self = shift;
1651     my $data = shift || return;
1652     puke "Argument to ", __PACKAGE__, "->values must be a \\%hash"
1653         unless ref $data eq 'HASH';
1654
1655     my @all_bind;
1656     foreach my $k (sort keys %$data) {
1657         my $v = $data->{$k};
1658         $self->_SWITCH_refkind($v, {
1659           ARRAYREF => sub {
1660             if ($self->{array_datatypes}) { # array datatype
1661               push @all_bind, $self->_bindtype($k, $v);
1662             }
1663             else {                          # literal SQL with bind
1664               my ($sql, @bind) = @$v;
1665               $self->_assert_bindval_matches_bindtype(@bind);
1666               push @all_bind, @bind;
1667             }
1668           },
1669           ARRAYREFREF => sub { # literal SQL with bind
1670             my ($sql, @bind) = @${$v};
1671             $self->_assert_bindval_matches_bindtype(@bind);
1672             push @all_bind, @bind;
1673           },
1674           SCALARREF => sub {  # literal SQL without bind
1675           },
1676           SCALAR_or_UNDEF => sub {
1677             push @all_bind, $self->_bindtype($k, $v);
1678           },
1679         });
1680     }
1681
1682     return @all_bind;
1683 }
1684
1685 sub generate {
1686     my $self  = shift;
1687
1688     my(@sql, @sqlq, @sqlv);
1689
1690     for (@_) {
1691         my $ref = ref $_;
1692         if ($ref eq 'HASH') {
1693             for my $k (sort keys %$_) {
1694                 my $v = $_->{$k};
1695                 my $r = ref $v;
1696                 my $label = $self->_quote($k);
1697                 if ($r eq 'ARRAY') {
1698                     # literal SQL with bind
1699                     my ($sql, @bind) = @$v;
1700                     $self->_assert_bindval_matches_bindtype(@bind);
1701                     push @sqlq, "$label = $sql";
1702                     push @sqlv, @bind;
1703                 } elsif ($r eq 'SCALAR') {
1704                     # literal SQL without bind
1705                     push @sqlq, "$label = $$v";
1706                 } else {
1707                     push @sqlq, "$label = ?";
1708                     push @sqlv, $self->_bindtype($k, $v);
1709                 }
1710             }
1711             push @sql, $self->_sqlcase('set'), join ', ', @sqlq;
1712         } elsif ($ref eq 'ARRAY') {
1713             # unlike insert(), assume these are ONLY the column names, i.e. for SQL
1714             for my $v (@$_) {
1715                 my $r = ref $v;
1716                 if ($r eq 'ARRAY') {   # literal SQL with bind
1717                     my ($sql, @bind) = @$v;
1718                     $self->_assert_bindval_matches_bindtype(@bind);
1719                     push @sqlq, $sql;
1720                     push @sqlv, @bind;
1721                 } elsif ($r eq 'SCALAR') {  # literal SQL without bind
1722                     # embedded literal SQL
1723                     push @sqlq, $$v;
1724                 } else {
1725                     push @sqlq, '?';
1726                     push @sqlv, $v;
1727                 }
1728             }
1729             push @sql, '(' . join(', ', @sqlq) . ')';
1730         } elsif ($ref eq 'SCALAR') {
1731             # literal SQL
1732             push @sql, $$_;
1733         } else {
1734             # strings get case twiddled
1735             push @sql, $self->_sqlcase($_);
1736         }
1737     }
1738
1739     my $sql = join ' ', @sql;
1740
1741     # this is pretty tricky
1742     # if ask for an array, return ($stmt, @bind)
1743     # otherwise, s/?/shift @sqlv/ to put it inline
1744     if (wantarray) {
1745         return ($sql, @sqlv);
1746     } else {
1747         1 while $sql =~ s/\?/my $d = shift(@sqlv);
1748                              ref $d ? $d->[1] : $d/e;
1749         return $sql;
1750     }
1751 }
1752
1753
1754 sub DESTROY { 1 }
1755
1756 sub AUTOLOAD {
1757     # This allows us to check for a local, then _form, attr
1758     my $self = shift;
1759     my($name) = $AUTOLOAD =~ /.*::(.+)/;
1760     puke "AUTOLOAD invoked for method name ${name} and allow_autoload option not set" unless $self->{allow_autoload};
1761     return $self->generate($name, @_);
1762 }
1763
1764 1;
1765
1766
1767
1768 __END__
1769
1770 =head1 NAME
1771
1772 SQL::Abstract - Generate SQL from Perl data structures
1773
1774 =head1 SYNOPSIS
1775
1776     use SQL::Abstract;
1777
1778     my $sql = SQL::Abstract->new;
1779
1780     my($stmt, @bind) = $sql->select($source, \@fields, \%where, $order);
1781
1782     my($stmt, @bind) = $sql->insert($table, \%fieldvals || \@values);
1783
1784     my($stmt, @bind) = $sql->update($table, \%fieldvals, \%where);
1785
1786     my($stmt, @bind) = $sql->delete($table, \%where);
1787
1788     # Then, use these in your DBI statements
1789     my $sth = $dbh->prepare($stmt);
1790     $sth->execute(@bind);
1791
1792     # Just generate the WHERE clause
1793     my($stmt, @bind) = $sql->where(\%where, $order);
1794
1795     # Return values in the same order, for hashed queries
1796     # See PERFORMANCE section for more details
1797     my @bind = $sql->values(\%fieldvals);
1798
1799 =head1 DESCRIPTION
1800
1801 This module was inspired by the excellent L<DBIx::Abstract>.
1802 However, in using that module I found that what I really wanted
1803 to do was generate SQL, but still retain complete control over my
1804 statement handles and use the DBI interface. So, I set out to
1805 create an abstract SQL generation module.
1806
1807 While based on the concepts used by L<DBIx::Abstract>, there are
1808 several important differences, especially when it comes to WHERE
1809 clauses. I have modified the concepts used to make the SQL easier
1810 to generate from Perl data structures and, IMO, more intuitive.
1811 The underlying idea is for this module to do what you mean, based
1812 on the data structures you provide it. The big advantage is that
1813 you don't have to modify your code every time your data changes,
1814 as this module figures it out.
1815
1816 To begin with, an SQL INSERT is as easy as just specifying a hash
1817 of C<key=value> pairs:
1818
1819     my %data = (
1820         name => 'Jimbo Bobson',
1821         phone => '123-456-7890',
1822         address => '42 Sister Lane',
1823         city => 'St. Louis',
1824         state => 'Louisiana',
1825     );
1826
1827 The SQL can then be generated with this:
1828
1829     my($stmt, @bind) = $sql->insert('people', \%data);
1830
1831 Which would give you something like this:
1832
1833     $stmt = "INSERT INTO people
1834                     (address, city, name, phone, state)
1835                     VALUES (?, ?, ?, ?, ?)";
1836     @bind = ('42 Sister Lane', 'St. Louis', 'Jimbo Bobson',
1837              '123-456-7890', 'Louisiana');
1838
1839 These are then used directly in your DBI code:
1840
1841     my $sth = $dbh->prepare($stmt);
1842     $sth->execute(@bind);
1843
1844 =head2 Inserting and Updating Arrays
1845
1846 If your database has array types (like for example Postgres),
1847 activate the special option C<< array_datatypes => 1 >>
1848 when creating the C<SQL::Abstract> object.
1849 Then you may use an arrayref to insert and update database array types:
1850
1851     my $sql = SQL::Abstract->new(array_datatypes => 1);
1852     my %data = (
1853         planets => [qw/Mercury Venus Earth Mars/]
1854     );
1855
1856     my($stmt, @bind) = $sql->insert('solar_system', \%data);
1857
1858 This results in:
1859
1860     $stmt = "INSERT INTO solar_system (planets) VALUES (?)"
1861
1862     @bind = (['Mercury', 'Venus', 'Earth', 'Mars']);
1863
1864
1865 =head2 Inserting and Updating SQL
1866
1867 In order to apply SQL functions to elements of your C<%data> you may
1868 specify a reference to an arrayref for the given hash value. For example,
1869 if you need to execute the Oracle C<to_date> function on a value, you can
1870 say something like this:
1871
1872     my %data = (
1873         name => 'Bill',
1874         date_entered => \[ "to_date(?,'MM/DD/YYYY')", "03/02/2003" ],
1875     );
1876
1877 The first value in the array is the actual SQL. Any other values are
1878 optional and would be included in the bind values array. This gives
1879 you:
1880
1881     my($stmt, @bind) = $sql->insert('people', \%data);
1882
1883     $stmt = "INSERT INTO people (name, date_entered)
1884                 VALUES (?, to_date(?,'MM/DD/YYYY'))";
1885     @bind = ('Bill', '03/02/2003');
1886
1887 An UPDATE is just as easy, all you change is the name of the function:
1888
1889     my($stmt, @bind) = $sql->update('people', \%data);
1890
1891 Notice that your C<%data> isn't touched; the module will generate
1892 the appropriately quirky SQL for you automatically. Usually you'll
1893 want to specify a WHERE clause for your UPDATE, though, which is
1894 where handling C<%where> hashes comes in handy...
1895
1896 =head2 Complex where statements
1897
1898 This module can generate pretty complicated WHERE statements
1899 easily. For example, simple C<key=value> pairs are taken to mean
1900 equality, and if you want to see if a field is within a set
1901 of values, you can use an arrayref. Let's say we wanted to
1902 SELECT some data based on this criteria:
1903
1904     my %where = (
1905        requestor => 'inna',
1906        worker => ['nwiger', 'rcwe', 'sfz'],
1907        status => { '!=', 'completed' }
1908     );
1909
1910     my($stmt, @bind) = $sql->select('tickets', '*', \%where);
1911
1912 The above would give you something like this:
1913
1914     $stmt = "SELECT * FROM tickets WHERE
1915                 ( requestor = ? ) AND ( status != ? )
1916                 AND ( worker = ? OR worker = ? OR worker = ? )";
1917     @bind = ('inna', 'completed', 'nwiger', 'rcwe', 'sfz');
1918
1919 Which you could then use in DBI code like so:
1920
1921     my $sth = $dbh->prepare($stmt);
1922     $sth->execute(@bind);
1923
1924 Easy, eh?
1925
1926 =head1 METHODS
1927
1928 The methods are simple. There's one for every major SQL operation,
1929 and a constructor you use first. The arguments are specified in a
1930 similar order for each method (table, then fields, then a where
1931 clause) to try and simplify things.
1932
1933 =head2 new(option => 'value')
1934
1935 The C<new()> function takes a list of options and values, and returns
1936 a new B<SQL::Abstract> object which can then be used to generate SQL
1937 through the methods below. The options accepted are:
1938
1939 =over
1940
1941 =item case
1942
1943 If set to 'lower', then SQL will be generated in all lowercase. By
1944 default SQL is generated in "textbook" case meaning something like:
1945
1946     SELECT a_field FROM a_table WHERE some_field LIKE '%someval%'
1947
1948 Any setting other than 'lower' is ignored.
1949
1950 =item cmp
1951
1952 This determines what the default comparison operator is. By default
1953 it is C<=>, meaning that a hash like this:
1954
1955     %where = (name => 'nwiger', email => 'nate@wiger.org');
1956
1957 Will generate SQL like this:
1958
1959     WHERE name = 'nwiger' AND email = 'nate@wiger.org'
1960
1961 However, you may want loose comparisons by default, so if you set
1962 C<cmp> to C<like> you would get SQL such as:
1963
1964     WHERE name like 'nwiger' AND email like 'nate@wiger.org'
1965
1966 You can also override the comparison on an individual basis - see
1967 the huge section on L</"WHERE CLAUSES"> at the bottom.
1968
1969 =item sqltrue, sqlfalse
1970
1971 Expressions for inserting boolean values within SQL statements.
1972 By default these are C<1=1> and C<1=0>. They are used
1973 by the special operators C<-in> and C<-not_in> for generating
1974 correct SQL even when the argument is an empty array (see below).
1975
1976 =item logic
1977
1978 This determines the default logical operator for multiple WHERE
1979 statements in arrays or hashes. If absent, the default logic is "or"
1980 for arrays, and "and" for hashes. This means that a WHERE
1981 array of the form:
1982
1983     @where = (
1984         event_date => {'>=', '2/13/99'},
1985         event_date => {'<=', '4/24/03'},
1986     );
1987
1988 will generate SQL like this:
1989
1990     WHERE event_date >= '2/13/99' OR event_date <= '4/24/03'
1991
1992 This is probably not what you want given this query, though (look
1993 at the dates). To change the "OR" to an "AND", simply specify:
1994
1995     my $sql = SQL::Abstract->new(logic => 'and');
1996
1997 Which will change the above C<WHERE> to:
1998
1999     WHERE event_date >= '2/13/99' AND event_date <= '4/24/03'
2000
2001 The logic can also be changed locally by inserting
2002 a modifier in front of an arrayref:
2003
2004     @where = (-and => [event_date => {'>=', '2/13/99'},
2005                        event_date => {'<=', '4/24/03'} ]);
2006
2007 See the L</"WHERE CLAUSES"> section for explanations.
2008
2009 =item convert
2010
2011 This will automatically convert comparisons using the specified SQL
2012 function for both column and value. This is mostly used with an argument
2013 of C<upper> or C<lower>, so that the SQL will have the effect of
2014 case-insensitive "searches". For example, this:
2015
2016     $sql = SQL::Abstract->new(convert => 'upper');
2017     %where = (keywords => 'MaKe iT CAse inSeNSItive');
2018
2019 Will turn out the following SQL:
2020
2021     WHERE upper(keywords) like upper('MaKe iT CAse inSeNSItive')
2022
2023 The conversion can be C<upper()>, C<lower()>, or any other SQL function
2024 that can be applied symmetrically to fields (actually B<SQL::Abstract> does
2025 not validate this option; it will just pass through what you specify verbatim).
2026
2027 =item bindtype
2028
2029 This is a kludge because many databases suck. For example, you can't
2030 just bind values using DBI's C<execute()> for Oracle C<CLOB> or C<BLOB> fields.
2031 Instead, you have to use C<bind_param()>:
2032
2033     $sth->bind_param(1, 'reg data');
2034     $sth->bind_param(2, $lots, {ora_type => ORA_CLOB});
2035
2036 The problem is, B<SQL::Abstract> will normally just return a C<@bind> array,
2037 which loses track of which field each slot refers to. Fear not.
2038
2039 If you specify C<bindtype> in new, you can determine how C<@bind> is returned.
2040 Currently, you can specify either C<normal> (default) or C<columns>. If you
2041 specify C<columns>, you will get an array that looks like this:
2042
2043     my $sql = SQL::Abstract->new(bindtype => 'columns');
2044     my($stmt, @bind) = $sql->insert(...);
2045
2046     @bind = (
2047         [ 'column1', 'value1' ],
2048         [ 'column2', 'value2' ],
2049         [ 'column3', 'value3' ],
2050     );
2051
2052 You can then iterate through this manually, using DBI's C<bind_param()>.
2053
2054     $sth->prepare($stmt);
2055     my $i = 1;
2056     for (@bind) {
2057         my($col, $data) = @$_;
2058         if ($col eq 'details' || $col eq 'comments') {
2059             $sth->bind_param($i, $data, {ora_type => ORA_CLOB});
2060         } elsif ($col eq 'image') {
2061             $sth->bind_param($i, $data, {ora_type => ORA_BLOB});
2062         } else {
2063             $sth->bind_param($i, $data);
2064         }
2065         $i++;
2066     }
2067     $sth->execute;      # execute without @bind now
2068
2069 Now, why would you still use B<SQL::Abstract> if you have to do this crap?
2070 Basically, the advantage is still that you don't have to care which fields
2071 are or are not included. You could wrap that above C<for> loop in a simple
2072 sub called C<bind_fields()> or something and reuse it repeatedly. You still
2073 get a layer of abstraction over manual SQL specification.
2074
2075 Note that if you set L</bindtype> to C<columns>, the C<\[ $sql, @bind ]>
2076 construct (see L</Literal SQL with placeholders and bind values (subqueries)>)
2077 will expect the bind values in this format.
2078
2079 =item quote_char
2080
2081 This is the character that a table or column name will be quoted
2082 with.  By default this is an empty string, but you could set it to
2083 the character C<`>, to generate SQL like this:
2084
2085   SELECT `a_field` FROM `a_table` WHERE `some_field` LIKE '%someval%'
2086
2087 Alternatively, you can supply an array ref of two items, the first being the left
2088 hand quote character, and the second the right hand quote character. For
2089 example, you could supply C<['[',']']> for SQL Server 2000 compliant quotes
2090 that generates SQL like this:
2091
2092   SELECT [a_field] FROM [a_table] WHERE [some_field] LIKE '%someval%'
2093
2094 Quoting is useful if you have tables or columns names that are reserved
2095 words in your database's SQL dialect.
2096
2097 =item escape_char
2098
2099 This is the character that will be used to escape L</quote_char>s appearing
2100 in an identifier before it has been quoted.
2101
2102 The parameter default in case of a single L</quote_char> character is the quote
2103 character itself.
2104
2105 When opening-closing-style quoting is used (L</quote_char> is an arrayref)
2106 this parameter defaults to the B<closing (right)> L</quote_char>. Occurrences
2107 of the B<opening (left)> L</quote_char> within the identifier are currently left
2108 untouched. The default for opening-closing-style quotes may change in future
2109 versions, thus you are B<strongly encouraged> to specify the escape character
2110 explicitly.
2111
2112 =item name_sep
2113
2114 This is the character that separates a table and column name.  It is
2115 necessary to specify this when the C<quote_char> option is selected,
2116 so that tables and column names can be individually quoted like this:
2117
2118   SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1
2119
2120 =item injection_guard
2121
2122 A regular expression C<qr/.../> that is applied to any C<-function> and unquoted
2123 column name specified in a query structure. This is a safety mechanism to avoid
2124 injection attacks when mishandling user input e.g.:
2125
2126   my %condition_as_column_value_pairs = get_values_from_user();
2127   $sqla->select( ... , \%condition_as_column_value_pairs );
2128
2129 If the expression matches an exception is thrown. Note that literal SQL
2130 supplied via C<\'...'> or C<\['...']> is B<not> checked in any way.
2131
2132 Defaults to checking for C<;> and the C<GO> keyword (TransactSQL)
2133
2134 =item array_datatypes
2135
2136 When this option is true, arrayrefs in INSERT or UPDATE are
2137 interpreted as array datatypes and are passed directly
2138 to the DBI layer.
2139 When this option is false, arrayrefs are interpreted
2140 as literal SQL, just like refs to arrayrefs
2141 (but this behavior is for backwards compatibility; when writing
2142 new queries, use the "reference to arrayref" syntax
2143 for literal SQL).
2144
2145
2146 =item special_ops
2147
2148 Takes a reference to a list of "special operators"
2149 to extend the syntax understood by L<SQL::Abstract>.
2150 See section L</"SPECIAL OPERATORS"> for details.
2151
2152 =item unary_ops
2153
2154 Takes a reference to a list of "unary operators"
2155 to extend the syntax understood by L<SQL::Abstract>.
2156 See section L</"UNARY OPERATORS"> for details.
2157
2158
2159
2160 =back
2161
2162 =head2 insert($table, \@values || \%fieldvals, \%options)
2163
2164 This is the simplest function. You simply give it a table name
2165 and either an arrayref of values or hashref of field/value pairs.
2166 It returns an SQL INSERT statement and a list of bind values.
2167 See the sections on L</"Inserting and Updating Arrays"> and
2168 L</"Inserting and Updating SQL"> for information on how to insert
2169 with those data types.
2170
2171 The optional C<\%options> hash reference may contain additional
2172 options to generate the insert SQL. Currently supported options
2173 are:
2174
2175 =over 4
2176
2177 =item returning
2178
2179 Takes either a scalar of raw SQL fields, or an array reference of
2180 field names, and adds on an SQL C<RETURNING> statement at the end.
2181 This allows you to return data generated by the insert statement
2182 (such as row IDs) without performing another C<SELECT> statement.
2183 Note, however, this is not part of the SQL standard and may not
2184 be supported by all database engines.
2185
2186 =back
2187
2188 =head2 update($table, \%fieldvals, \%where, \%options)
2189
2190 This takes a table, hashref of field/value pairs, and an optional
2191 hashref L<WHERE clause|/WHERE CLAUSES>. It returns an SQL UPDATE function and a list
2192 of bind values.
2193 See the sections on L</"Inserting and Updating Arrays"> and
2194 L</"Inserting and Updating SQL"> for information on how to insert
2195 with those data types.
2196
2197 The optional C<\%options> hash reference may contain additional
2198 options to generate the update SQL. Currently supported options
2199 are:
2200
2201 =over 4
2202
2203 =item returning
2204
2205 See the C<returning> option to
2206 L<insert|/insert($table, \@values || \%fieldvals, \%options)>.
2207
2208 =back
2209
2210 =head2 select($source, $fields, $where, $order)
2211
2212 This returns a SQL SELECT statement and associated list of bind values, as
2213 specified by the arguments:
2214
2215 =over
2216
2217 =item $source
2218
2219 Specification of the 'FROM' part of the statement.
2220 The argument can be either a plain scalar (interpreted as a table
2221 name, will be quoted), or an arrayref (interpreted as a list
2222 of table names, joined by commas, quoted), or a scalarref
2223 (literal SQL, not quoted).
2224
2225 =item $fields
2226
2227 Specification of the list of fields to retrieve from
2228 the source.
2229 The argument can be either an arrayref (interpreted as a list
2230 of field names, will be joined by commas and quoted), or a
2231 plain scalar (literal SQL, not quoted).
2232 Please observe that this API is not as flexible as that of
2233 the first argument C<$source>, for backwards compatibility reasons.
2234
2235 =item $where
2236
2237 Optional argument to specify the WHERE part of the query.
2238 The argument is most often a hashref, but can also be
2239 an arrayref or plain scalar --
2240 see section L<WHERE clause|/"WHERE CLAUSES"> for details.
2241
2242 =item $order
2243
2244 Optional argument to specify the ORDER BY part of the query.
2245 The argument can be a scalar, a hashref or an arrayref
2246 -- see section L<ORDER BY clause|/"ORDER BY CLAUSES">
2247 for details.
2248
2249 =back
2250
2251
2252 =head2 delete($table, \%where, \%options)
2253
2254 This takes a table name and optional hashref L<WHERE clause|/WHERE CLAUSES>.
2255 It returns an SQL DELETE statement and list of bind values.
2256
2257 The optional C<\%options> hash reference may contain additional
2258 options to generate the delete SQL. Currently supported options
2259 are:
2260
2261 =over 4
2262
2263 =item returning
2264
2265 See the C<returning> option to
2266 L<insert|/insert($table, \@values || \%fieldvals, \%options)>.
2267
2268 =back
2269
2270 =head2 where(\%where, $order)
2271
2272 This is used to generate just the WHERE clause. For example,
2273 if you have an arbitrary data structure and know what the
2274 rest of your SQL is going to look like, but want an easy way
2275 to produce a WHERE clause, use this. It returns an SQL WHERE
2276 clause and list of bind values.
2277
2278
2279 =head2 values(\%data)
2280
2281 This just returns the values from the hash C<%data>, in the same
2282 order that would be returned from any of the other above queries.
2283 Using this allows you to markedly speed up your queries if you
2284 are affecting lots of rows. See below under the L</"PERFORMANCE"> section.
2285
2286 =head2 generate($any, 'number', $of, \@data, $struct, \%types)
2287
2288 Warning: This is an experimental method and subject to change.
2289
2290 This returns arbitrarily generated SQL. It's a really basic shortcut.
2291 It will return two different things, depending on return context:
2292
2293     my($stmt, @bind) = $sql->generate('create table', \$table, \@fields);
2294     my $stmt_and_val = $sql->generate('create table', \$table, \@fields);
2295
2296 These would return the following:
2297
2298     # First calling form
2299     $stmt = "CREATE TABLE test (?, ?)";
2300     @bind = (field1, field2);
2301
2302     # Second calling form
2303     $stmt_and_val = "CREATE TABLE test (field1, field2)";
2304
2305 Depending on what you're trying to do, it's up to you to choose the correct
2306 format. In this example, the second form is what you would want.
2307
2308 By the same token:
2309
2310     $sql->generate('alter session', { nls_date_format => 'MM/YY' });
2311
2312 Might give you:
2313
2314     ALTER SESSION SET nls_date_format = 'MM/YY'
2315
2316 You get the idea. Strings get their case twiddled, but everything
2317 else remains verbatim.
2318
2319 =head1 EXPORTABLE FUNCTIONS
2320
2321 =head2 is_plain_value
2322
2323 Determines if the supplied argument is a plain value as understood by this
2324 module:
2325
2326 =over
2327
2328 =item * The value is C<undef>
2329
2330 =item * The value is a non-reference
2331
2332 =item * The value is an object with stringification overloading
2333
2334 =item * The value is of the form C<< { -value => $anything } >>
2335
2336 =back
2337
2338 On failure returns C<undef>, on success returns a B<scalar> reference
2339 to the original supplied argument.
2340
2341 =over
2342
2343 =item * Note
2344
2345 The stringification overloading detection is rather advanced: it takes
2346 into consideration not only the presence of a C<""> overload, but if that
2347 fails also checks for enabled
2348 L<autogenerated versions of C<"">|overload/Magic Autogeneration>, based
2349 on either C<0+> or C<bool>.
2350
2351 Unfortunately testing in the field indicates that this
2352 detection B<< may tickle a latent bug in perl versions before 5.018 >>,
2353 but only when very large numbers of stringifying objects are involved.
2354 At the time of writing ( Sep 2014 ) there is no clear explanation of
2355 the direct cause, nor is there a manageably small test case that reliably
2356 reproduces the problem.
2357
2358 If you encounter any of the following exceptions in B<random places within
2359 your application stack> - this module may be to blame:
2360
2361   Operation "ne": no method found,
2362     left argument in overloaded package <something>,
2363     right argument in overloaded package <something>
2364
2365 or perhaps even
2366
2367   Stub found while resolving method "???" overloading """" in package <something>
2368
2369 If you fall victim to the above - please attempt to reduce the problem
2370 to something that could be sent to the L<SQL::Abstract developers
2371 |DBIx::Class/GETTING HELP/SUPPORT>
2372 (either publicly or privately). As a workaround in the meantime you can
2373 set C<$ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}> to a true
2374 value, which will most likely eliminate your problem (at the expense of
2375 not being able to properly detect exotic forms of stringification).
2376
2377 This notice and environment variable will be removed in a future version,
2378 as soon as the underlying problem is found and a reliable workaround is
2379 devised.
2380
2381 =back
2382
2383 =head2 is_literal_value
2384
2385 Determines if the supplied argument is a literal value as understood by this
2386 module:
2387
2388 =over
2389
2390 =item * C<\$sql_string>
2391
2392 =item * C<\[ $sql_string, @bind_values ]>
2393
2394 =back
2395
2396 On failure returns C<undef>, on success returns an B<array> reference
2397 containing the unpacked version of the supplied literal SQL and bind values.
2398
2399 =head1 WHERE CLAUSES
2400
2401 =head2 Introduction
2402
2403 This module uses a variation on the idea from L<DBIx::Abstract>. It
2404 is B<NOT>, repeat I<not> 100% compatible. B<The main logic of this
2405 module is that things in arrays are OR'ed, and things in hashes
2406 are AND'ed.>
2407
2408 The easiest way to explain is to show lots of examples. After
2409 each C<%where> hash shown, it is assumed you used:
2410
2411     my($stmt, @bind) = $sql->where(\%where);
2412
2413 However, note that the C<%where> hash can be used directly in any
2414 of the other functions as well, as described above.
2415
2416 =head2 Key-value pairs
2417
2418 So, let's get started. To begin, a simple hash:
2419
2420     my %where  = (
2421         user   => 'nwiger',
2422         status => 'completed'
2423     );
2424
2425 Is converted to SQL C<key = val> statements:
2426
2427     $stmt = "WHERE user = ? AND status = ?";
2428     @bind = ('nwiger', 'completed');
2429
2430 One common thing I end up doing is having a list of values that
2431 a field can be in. To do this, simply specify a list inside of
2432 an arrayref:
2433
2434     my %where  = (
2435         user   => 'nwiger',
2436         status => ['assigned', 'in-progress', 'pending'];
2437     );
2438
2439 This simple code will create the following:
2440
2441     $stmt = "WHERE user = ? AND ( status = ? OR status = ? OR status = ? )";
2442     @bind = ('nwiger', 'assigned', 'in-progress', 'pending');
2443
2444 A field associated to an empty arrayref will be considered a
2445 logical false and will generate 0=1.
2446
2447 =head2 Tests for NULL values
2448
2449 If the value part is C<undef> then this is converted to SQL <IS NULL>
2450
2451     my %where  = (
2452         user   => 'nwiger',
2453         status => undef,
2454     );
2455
2456 becomes:
2457
2458     $stmt = "WHERE user = ? AND status IS NULL";
2459     @bind = ('nwiger');
2460
2461 To test if a column IS NOT NULL:
2462
2463     my %where  = (
2464         user   => 'nwiger',
2465         status => { '!=', undef },
2466     );
2467
2468 =head2 Specific comparison operators
2469
2470 If you want to specify a different type of operator for your comparison,
2471 you can use a hashref for a given column:
2472
2473     my %where  = (
2474         user   => 'nwiger',
2475         status => { '!=', 'completed' }
2476     );
2477
2478 Which would generate:
2479
2480     $stmt = "WHERE user = ? AND status != ?";
2481     @bind = ('nwiger', 'completed');
2482
2483 To test against multiple values, just enclose the values in an arrayref:
2484
2485     status => { '=', ['assigned', 'in-progress', 'pending'] };
2486
2487 Which would give you:
2488
2489     "WHERE status = ? OR status = ? OR status = ?"
2490
2491
2492 The hashref can also contain multiple pairs, in which case it is expanded
2493 into an C<AND> of its elements:
2494
2495     my %where  = (
2496         user   => 'nwiger',
2497         status => { '!=', 'completed', -not_like => 'pending%' }
2498     );
2499
2500     # Or more dynamically, like from a form
2501     $where{user} = 'nwiger';
2502     $where{status}{'!='} = 'completed';
2503     $where{status}{'-not_like'} = 'pending%';
2504
2505     # Both generate this
2506     $stmt = "WHERE user = ? AND status != ? AND status NOT LIKE ?";
2507     @bind = ('nwiger', 'completed', 'pending%');
2508
2509
2510 To get an OR instead, you can combine it with the arrayref idea:
2511
2512     my %where => (
2513          user => 'nwiger',
2514          priority => [ { '=', 2 }, { '>', 5 } ]
2515     );
2516
2517 Which would generate:
2518
2519     $stmt = "WHERE ( priority = ? OR priority > ? ) AND user = ?";
2520     @bind = ('2', '5', 'nwiger');
2521
2522 If you want to include literal SQL (with or without bind values), just use a
2523 scalar reference or reference to an arrayref as the value:
2524
2525     my %where  = (
2526         date_entered => { '>' => \["to_date(?, 'MM/DD/YYYY')", "11/26/2008"] },
2527         date_expires => { '<' => \"now()" }
2528     );
2529
2530 Which would generate:
2531
2532     $stmt = "WHERE date_entered > to_date(?, 'MM/DD/YYYY') AND date_expires < now()";
2533     @bind = ('11/26/2008');
2534
2535
2536 =head2 Logic and nesting operators
2537
2538 In the example above,
2539 there is a subtle trap if you want to say something like
2540 this (notice the C<AND>):
2541
2542     WHERE priority != ? AND priority != ?
2543
2544 Because, in Perl you I<can't> do this:
2545
2546     priority => { '!=' => 2, '!=' => 1 }
2547
2548 As the second C<!=> key will obliterate the first. The solution
2549 is to use the special C<-modifier> form inside an arrayref:
2550
2551     priority => [ -and => {'!=', 2},
2552                           {'!=', 1} ]
2553
2554
2555 Normally, these would be joined by C<OR>, but the modifier tells it
2556 to use C<AND> instead. (Hint: You can use this in conjunction with the
2557 C<logic> option to C<new()> in order to change the way your queries
2558 work by default.) B<Important:> Note that the C<-modifier> goes
2559 B<INSIDE> the arrayref, as an extra first element. This will
2560 B<NOT> do what you think it might:
2561
2562     priority => -and => [{'!=', 2}, {'!=', 1}]   # WRONG!
2563
2564 Here is a quick list of equivalencies, since there is some overlap:
2565
2566     # Same
2567     status => {'!=', 'completed', 'not like', 'pending%' }
2568     status => [ -and => {'!=', 'completed'}, {'not like', 'pending%'}]
2569
2570     # Same
2571     status => {'=', ['assigned', 'in-progress']}
2572     status => [ -or => {'=', 'assigned'}, {'=', 'in-progress'}]
2573     status => [ {'=', 'assigned'}, {'=', 'in-progress'} ]
2574
2575
2576
2577 =head2 Special operators: IN, BETWEEN, etc.
2578
2579 You can also use the hashref format to compare a list of fields using the
2580 C<IN> comparison operator, by specifying the list as an arrayref:
2581
2582     my %where  = (
2583         status   => 'completed',
2584         reportid => { -in => [567, 2335, 2] }
2585     );
2586
2587 Which would generate:
2588
2589     $stmt = "WHERE status = ? AND reportid IN (?,?,?)";
2590     @bind = ('completed', '567', '2335', '2');
2591
2592 The reverse operator C<-not_in> generates SQL C<NOT IN> and is used in
2593 the same way.
2594
2595 If the argument to C<-in> is an empty array, 'sqlfalse' is generated
2596 (by default: C<1=0>). Similarly, C<< -not_in => [] >> generates
2597 'sqltrue' (by default: C<1=1>).
2598
2599 In addition to the array you can supply a chunk of literal sql or
2600 literal sql with bind:
2601
2602     my %where = {
2603       customer => { -in => \[
2604         'SELECT cust_id FROM cust WHERE balance > ?',
2605         2000,
2606       ],
2607       status => { -in => \'SELECT status_codes FROM states' },
2608     };
2609
2610 would generate:
2611
2612     $stmt = "WHERE (
2613           customer IN ( SELECT cust_id FROM cust WHERE balance > ? )
2614       AND status IN ( SELECT status_codes FROM states )
2615     )";
2616     @bind = ('2000');
2617
2618 Finally, if the argument to C<-in> is not a reference, it will be
2619 treated as a single-element array.
2620
2621 Another pair of operators is C<-between> and C<-not_between>,
2622 used with an arrayref of two values:
2623
2624     my %where  = (
2625         user   => 'nwiger',
2626         completion_date => {
2627            -not_between => ['2002-10-01', '2003-02-06']
2628         }
2629     );
2630
2631 Would give you:
2632
2633     WHERE user = ? AND completion_date NOT BETWEEN ( ? AND ? )
2634
2635 Just like with C<-in> all plausible combinations of literal SQL
2636 are possible:
2637
2638     my %where = {
2639       start0 => { -between => [ 1, 2 ] },
2640       start1 => { -between => \["? AND ?", 1, 2] },
2641       start2 => { -between => \"lower(x) AND upper(y)" },
2642       start3 => { -between => [
2643         \"lower(x)",
2644         \["upper(?)", 'stuff' ],
2645       ] },
2646     };
2647
2648 Would give you:
2649
2650     $stmt = "WHERE (
2651           ( start0 BETWEEN ? AND ?                )
2652       AND ( start1 BETWEEN ? AND ?                )
2653       AND ( start2 BETWEEN lower(x) AND upper(y)  )
2654       AND ( start3 BETWEEN lower(x) AND upper(?)  )
2655     )";
2656     @bind = (1, 2, 1, 2, 'stuff');
2657
2658
2659 These are the two builtin "special operators"; but the
2660 list can be expanded: see section L</"SPECIAL OPERATORS"> below.
2661
2662 =head2 Unary operators: bool
2663
2664 If you wish to test against boolean columns or functions within your
2665 database you can use the C<-bool> and C<-not_bool> operators. For
2666 example to test the column C<is_user> being true and the column
2667 C<is_enabled> being false you would use:-
2668
2669     my %where  = (
2670         -bool       => 'is_user',
2671         -not_bool   => 'is_enabled',
2672     );
2673
2674 Would give you:
2675
2676     WHERE is_user AND NOT is_enabled
2677
2678 If a more complex combination is required, testing more conditions,
2679 then you should use the and/or operators:-
2680
2681     my %where  = (
2682         -and           => [
2683             -bool      => 'one',
2684             -not_bool  => { two=> { -rlike => 'bar' } },
2685             -not_bool  => { three => [ { '=', 2 }, { '>', 5 } ] },
2686         ],
2687     );
2688
2689 Would give you:
2690
2691     WHERE
2692       one
2693         AND
2694       (NOT two RLIKE ?)
2695         AND
2696       (NOT ( three = ? OR three > ? ))
2697
2698
2699 =head2 Nested conditions, -and/-or prefixes
2700
2701 So far, we've seen how multiple conditions are joined with a top-level
2702 C<AND>.  We can change this by putting the different conditions we want in
2703 hashes and then putting those hashes in an array. For example:
2704
2705     my @where = (
2706         {
2707             user   => 'nwiger',
2708             status => { -like => ['pending%', 'dispatched'] },
2709         },
2710         {
2711             user   => 'robot',
2712             status => 'unassigned',
2713         }
2714     );
2715
2716 This data structure would create the following:
2717
2718     $stmt = "WHERE ( user = ? AND ( status LIKE ? OR status LIKE ? ) )
2719                 OR ( user = ? AND status = ? ) )";
2720     @bind = ('nwiger', 'pending', 'dispatched', 'robot', 'unassigned');
2721
2722
2723 Clauses in hashrefs or arrayrefs can be prefixed with an C<-and> or C<-or>
2724 to change the logic inside:
2725
2726     my @where = (
2727          -and => [
2728             user => 'nwiger',
2729             [
2730                 -and => [ workhrs => {'>', 20}, geo => 'ASIA' ],
2731                 -or => { workhrs => {'<', 50}, geo => 'EURO' },
2732             ],
2733         ],
2734     );
2735
2736 That would yield:
2737
2738     $stmt = "WHERE ( user = ?
2739                AND ( ( workhrs > ? AND geo = ? )
2740                   OR ( workhrs < ? OR geo = ? ) ) )";
2741     @bind = ('nwiger', '20', 'ASIA', '50', 'EURO');
2742
2743 =head3 Algebraic inconsistency, for historical reasons
2744
2745 C<Important note>: when connecting several conditions, the C<-and->|C<-or>
2746 operator goes C<outside> of the nested structure; whereas when connecting
2747 several constraints on one column, the C<-and> operator goes
2748 C<inside> the arrayref. Here is an example combining both features:
2749
2750    my @where = (
2751      -and => [a => 1, b => 2],
2752      -or  => [c => 3, d => 4],
2753       e   => [-and => {-like => 'foo%'}, {-like => '%bar'} ]
2754    )
2755
2756 yielding
2757
2758   WHERE ( (    ( a = ? AND b = ? )
2759             OR ( c = ? OR d = ? )
2760             OR ( e LIKE ? AND e LIKE ? ) ) )
2761
2762 This difference in syntax is unfortunate but must be preserved for
2763 historical reasons. So be careful: the two examples below would
2764 seem algebraically equivalent, but they are not
2765
2766   { col => [ -and =>
2767     { -like => 'foo%' },
2768     { -like => '%bar' },
2769   ] }
2770   # yields: WHERE ( ( col LIKE ? AND col LIKE ? ) )
2771
2772   [ -and =>
2773     { col => { -like => 'foo%' } },
2774     { col => { -like => '%bar' } },
2775   ]
2776   # yields: WHERE ( ( col LIKE ? OR col LIKE ? ) )
2777
2778
2779 =head2 Literal SQL and value type operators
2780
2781 The basic premise of SQL::Abstract is that in WHERE specifications the "left
2782 side" is a column name and the "right side" is a value (normally rendered as
2783 a placeholder). This holds true for both hashrefs and arrayref pairs as you
2784 see in the L</WHERE CLAUSES> examples above. Sometimes it is necessary to
2785 alter this behavior. There are several ways of doing so.
2786
2787 =head3 -ident
2788
2789 This is a virtual operator that signals the string to its right side is an
2790 identifier (a column name) and not a value. For example to compare two
2791 columns you would write:
2792
2793     my %where = (
2794         priority => { '<', 2 },
2795         requestor => { -ident => 'submitter' },
2796     );
2797
2798 which creates:
2799
2800     $stmt = "WHERE priority < ? AND requestor = submitter";
2801     @bind = ('2');
2802
2803 If you are maintaining legacy code you may see a different construct as
2804 described in L</Deprecated usage of Literal SQL>, please use C<-ident> in new
2805 code.
2806
2807 =head3 -value
2808
2809 This is a virtual operator that signals that the construct to its right side
2810 is a value to be passed to DBI. This is for example necessary when you want
2811 to write a where clause against an array (for RDBMS that support such
2812 datatypes). For example:
2813
2814     my %where = (
2815         array => { -value => [1, 2, 3] }
2816     );
2817
2818 will result in:
2819
2820     $stmt = 'WHERE array = ?';
2821     @bind = ([1, 2, 3]);
2822
2823 Note that if you were to simply say:
2824
2825     my %where = (
2826         array => [1, 2, 3]
2827     );
2828
2829 the result would probably not be what you wanted:
2830
2831     $stmt = 'WHERE array = ? OR array = ? OR array = ?';
2832     @bind = (1, 2, 3);
2833
2834 =head3 Literal SQL
2835
2836 Finally, sometimes only literal SQL will do. To include a random snippet
2837 of SQL verbatim, you specify it as a scalar reference. Consider this only
2838 as a last resort. Usually there is a better way. For example:
2839
2840     my %where = (
2841         priority => { '<', 2 },
2842         requestor => { -in => \'(SELECT name FROM hitmen)' },
2843     );
2844
2845 Would create:
2846
2847     $stmt = "WHERE priority < ? AND requestor IN (SELECT name FROM hitmen)"
2848     @bind = (2);
2849
2850 Note that in this example, you only get one bind parameter back, since
2851 the verbatim SQL is passed as part of the statement.
2852
2853 =head4 CAVEAT
2854
2855   Never use untrusted input as a literal SQL argument - this is a massive
2856   security risk (there is no way to check literal snippets for SQL
2857   injections and other nastyness). If you need to deal with untrusted input
2858   use literal SQL with placeholders as described next.
2859
2860 =head3 Literal SQL with placeholders and bind values (subqueries)
2861
2862 If the literal SQL to be inserted has placeholders and bind values,
2863 use a reference to an arrayref (yes this is a double reference --
2864 not so common, but perfectly legal Perl). For example, to find a date
2865 in Postgres you can use something like this:
2866
2867     my %where = (
2868        date_column => \[ "= date '2008-09-30' - ?::integer", 10 ]
2869     )
2870
2871 This would create:
2872
2873     $stmt = "WHERE ( date_column = date '2008-09-30' - ?::integer )"
2874     @bind = ('10');
2875
2876 Note that you must pass the bind values in the same format as they are returned
2877 by L<where|/where(\%where, $order)>. This means that if you set L</bindtype>
2878 to C<columns>, you must provide the bind values in the
2879 C<< [ column_meta => value ] >> format, where C<column_meta> is an opaque
2880 scalar value; most commonly the column name, but you can use any scalar value
2881 (including references and blessed references), L<SQL::Abstract> will simply
2882 pass it through intact. So if C<bindtype> is set to C<columns> the above
2883 example will look like:
2884
2885     my %where = (
2886        date_column => \[ "= date '2008-09-30' - ?::integer", [ {} => 10 ] ]
2887     )
2888
2889 Literal SQL is especially useful for nesting parenthesized clauses in the
2890 main SQL query. Here is a first example:
2891
2892   my ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
2893                                100, "foo%");
2894   my %where = (
2895     foo => 1234,
2896     bar => \["IN ($sub_stmt)" => @sub_bind],
2897   );
2898
2899 This yields:
2900
2901   $stmt = "WHERE (foo = ? AND bar IN (SELECT c1 FROM t1
2902                                              WHERE c2 < ? AND c3 LIKE ?))";
2903   @bind = (1234, 100, "foo%");
2904
2905 Other subquery operators, like for example C<"E<gt> ALL"> or C<"NOT IN">,
2906 are expressed in the same way. Of course the C<$sub_stmt> and
2907 its associated bind values can be generated through a former call
2908 to C<select()> :
2909
2910   my ($sub_stmt, @sub_bind)
2911      = $sql->select("t1", "c1", {c2 => {"<" => 100},
2912                                  c3 => {-like => "foo%"}});
2913   my %where = (
2914     foo => 1234,
2915     bar => \["> ALL ($sub_stmt)" => @sub_bind],
2916   );
2917
2918 In the examples above, the subquery was used as an operator on a column;
2919 but the same principle also applies for a clause within the main C<%where>
2920 hash, like an EXISTS subquery:
2921
2922   my ($sub_stmt, @sub_bind)
2923      = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"});
2924   my %where = ( -and => [
2925     foo   => 1234,
2926     \["EXISTS ($sub_stmt)" => @sub_bind],
2927   ]);
2928
2929 which yields
2930
2931   $stmt = "WHERE (foo = ? AND EXISTS (SELECT * FROM t1
2932                                         WHERE c1 = ? AND c2 > t0.c0))";
2933   @bind = (1234, 1);
2934
2935
2936 Observe that the condition on C<c2> in the subquery refers to
2937 column C<t0.c0> of the main query: this is I<not> a bind
2938 value, so we have to express it through a scalar ref.
2939 Writing C<< c2 => {">" => "t0.c0"} >> would have generated
2940 C<< c2 > ? >> with bind value C<"t0.c0"> ... not exactly
2941 what we wanted here.
2942
2943 Finally, here is an example where a subquery is used
2944 for expressing unary negation:
2945
2946   my ($sub_stmt, @sub_bind)
2947      = $sql->where({age => [{"<" => 10}, {">" => 20}]});
2948   $sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause
2949   my %where = (
2950         lname  => {like => '%son%'},
2951         \["NOT ($sub_stmt)" => @sub_bind],
2952     );
2953
2954 This yields
2955
2956   $stmt = "lname LIKE ? AND NOT ( age < ? OR age > ? )"
2957   @bind = ('%son%', 10, 20)
2958
2959 =head3 Deprecated usage of Literal SQL
2960
2961 Below are some examples of archaic use of literal SQL. It is shown only as
2962 reference for those who deal with legacy code. Each example has a much
2963 better, cleaner and safer alternative that users should opt for in new code.
2964
2965 =over
2966
2967 =item *
2968
2969     my %where = ( requestor => \'IS NOT NULL' )
2970
2971     $stmt = "WHERE requestor IS NOT NULL"
2972
2973 This used to be the way of generating NULL comparisons, before the handling
2974 of C<undef> got formalized. For new code please use the superior syntax as
2975 described in L</Tests for NULL values>.
2976
2977 =item *
2978
2979     my %where = ( requestor => \'= submitter' )
2980
2981     $stmt = "WHERE requestor = submitter"
2982
2983 This used to be the only way to compare columns. Use the superior L</-ident>
2984 method for all new code. For example an identifier declared in such a way
2985 will be properly quoted if L</quote_char> is properly set, while the legacy
2986 form will remain as supplied.
2987
2988 =item *
2989
2990     my %where = ( is_ready  => \"", completed => { '>', '2012-12-21' } )
2991
2992     $stmt = "WHERE completed > ? AND is_ready"
2993     @bind = ('2012-12-21')
2994
2995 Using an empty string literal used to be the only way to express a boolean.
2996 For all new code please use the much more readable
2997 L<-bool|/Unary operators: bool> operator.
2998
2999 =back
3000
3001 =head2 Conclusion
3002
3003 These pages could go on for a while, since the nesting of the data
3004 structures this module can handle are pretty much unlimited (the
3005 module implements the C<WHERE> expansion as a recursive function
3006 internally). Your best bet is to "play around" with the module a
3007 little to see how the data structures behave, and choose the best
3008 format for your data based on that.
3009
3010 And of course, all the values above will probably be replaced with
3011 variables gotten from forms or the command line. After all, if you
3012 knew everything ahead of time, you wouldn't have to worry about
3013 dynamically-generating SQL and could just hardwire it into your
3014 script.
3015
3016 =head1 ORDER BY CLAUSES
3017
3018 Some functions take an order by clause. This can either be a scalar (just a
3019 column name), a hashref of C<< { -desc => 'col' } >> or C<< { -asc => 'col' }
3020 >>, a scalarref, an arrayref-ref, or an arrayref of any of the previous
3021 forms. Examples:
3022
3023                Given              |         Will Generate
3024     ---------------------------------------------------------------
3025                                   |
3026     'colA'                        | ORDER BY colA
3027                                   |
3028     [qw/colA colB/]               | ORDER BY colA, colB
3029                                   |
3030     {-asc  => 'colA'}             | ORDER BY colA ASC
3031                                   |
3032     {-desc => 'colB'}             | ORDER BY colB DESC
3033                                   |
3034     ['colA', {-asc => 'colB'}]    | ORDER BY colA, colB ASC
3035                                   |
3036     { -asc => [qw/colA colB/] }   | ORDER BY colA ASC, colB ASC
3037                                   |
3038     \'colA DESC'                  | ORDER BY colA DESC
3039                                   |
3040     \[ 'FUNC(colA, ?)', $x ]      | ORDER BY FUNC(colA, ?)
3041                                   |   /* ...with $x bound to ? */
3042                                   |
3043     [                             | ORDER BY
3044       { -asc => 'colA' },         |     colA ASC,
3045       { -desc => [qw/colB/] },    |     colB DESC,
3046       { -asc => [qw/colC colD/] },|     colC ASC, colD ASC,
3047       \'colE DESC',               |     colE DESC,
3048       \[ 'FUNC(colF, ?)', $x ],   |     FUNC(colF, ?)
3049     ]                             |   /* ...with $x bound to ? */
3050     ===============================================================
3051
3052
3053
3054 =head1 SPECIAL OPERATORS
3055
3056   my $sqlmaker = SQL::Abstract->new(special_ops => [
3057      {
3058       regex => qr/.../,
3059       handler => sub {
3060         my ($self, $field, $op, $arg) = @_;
3061         ...
3062       },
3063      },
3064      {
3065       regex => qr/.../,
3066       handler => 'method_name',
3067      },
3068    ]);
3069
3070 A "special operator" is a SQL syntactic clause that can be
3071 applied to a field, instead of a usual binary operator.
3072 For example:
3073
3074    WHERE field IN (?, ?, ?)
3075    WHERE field BETWEEN ? AND ?
3076    WHERE MATCH(field) AGAINST (?, ?)
3077
3078 Special operators IN and BETWEEN are fairly standard and therefore
3079 are builtin within C<SQL::Abstract> (as the overridable methods
3080 C<_where_field_IN> and C<_where_field_BETWEEN>). For other operators,
3081 like the MATCH .. AGAINST example above which is specific to MySQL,
3082 you can write your own operator handlers - supply a C<special_ops>
3083 argument to the C<new> method. That argument takes an arrayref of
3084 operator definitions; each operator definition is a hashref with two
3085 entries:
3086
3087 =over
3088
3089 =item regex
3090
3091 the regular expression to match the operator
3092
3093 =item handler
3094
3095 Either a coderef or a plain scalar method name. In both cases
3096 the expected return is C<< ($sql, @bind) >>.
3097
3098 When supplied with a method name, it is simply called on the
3099 L<SQL::Abstract> object as:
3100
3101  $self->$method_name($field, $op, $arg)
3102
3103  Where:
3104
3105   $field is the LHS of the operator
3106   $op is the part that matched the handler regex
3107   $arg is the RHS
3108
3109 When supplied with a coderef, it is called as:
3110
3111  $coderef->($self, $field, $op, $arg)
3112
3113
3114 =back
3115
3116 For example, here is an implementation
3117 of the MATCH .. AGAINST syntax for MySQL
3118
3119   my $sqlmaker = SQL::Abstract->new(special_ops => [
3120
3121     # special op for MySql MATCH (field) AGAINST(word1, word2, ...)
3122     {regex => qr/^match$/i,
3123      handler => sub {
3124        my ($self, $field, $op, $arg) = @_;
3125        $arg = [$arg] if not ref $arg;
3126        my $label         = $self->_quote($field);
3127        my ($placeholder) = $self->_convert('?');
3128        my $placeholders  = join ", ", (($placeholder) x @$arg);
3129        my $sql           = $self->_sqlcase('match') . " ($label) "
3130                          . $self->_sqlcase('against') . " ($placeholders) ";
3131        my @bind = $self->_bindtype($field, @$arg);
3132        return ($sql, @bind);
3133        }
3134      },
3135
3136   ]);
3137
3138
3139 =head1 UNARY OPERATORS
3140
3141   my $sqlmaker = SQL::Abstract->new(unary_ops => [
3142      {
3143       regex => qr/.../,
3144       handler => sub {
3145         my ($self, $op, $arg) = @_;
3146         ...
3147       },
3148      },
3149      {
3150       regex => qr/.../,
3151       handler => 'method_name',
3152      },
3153    ]);
3154
3155 A "unary operator" is a SQL syntactic clause that can be
3156 applied to a field - the operator goes before the field
3157
3158 You can write your own operator handlers - supply a C<unary_ops>
3159 argument to the C<new> method. That argument takes an arrayref of
3160 operator definitions; each operator definition is a hashref with two
3161 entries:
3162
3163 =over
3164
3165 =item regex
3166
3167 the regular expression to match the operator
3168
3169 =item handler
3170
3171 Either a coderef or a plain scalar method name. In both cases
3172 the expected return is C<< $sql >>.
3173
3174 When supplied with a method name, it is simply called on the
3175 L<SQL::Abstract> object as:
3176
3177  $self->$method_name($op, $arg)
3178
3179  Where:
3180
3181   $op is the part that matched the handler regex
3182   $arg is the RHS or argument of the operator
3183
3184 When supplied with a coderef, it is called as:
3185
3186  $coderef->($self, $op, $arg)
3187
3188
3189 =back
3190
3191
3192 =head1 PERFORMANCE
3193
3194 Thanks to some benchmarking by Mark Stosberg, it turns out that
3195 this module is many orders of magnitude faster than using C<DBIx::Abstract>.
3196 I must admit this wasn't an intentional design issue, but it's a
3197 byproduct of the fact that you get to control your C<DBI> handles
3198 yourself.
3199
3200 To maximize performance, use a code snippet like the following:
3201
3202     # prepare a statement handle using the first row
3203     # and then reuse it for the rest of the rows
3204     my($sth, $stmt);
3205     for my $href (@array_of_hashrefs) {
3206         $stmt ||= $sql->insert('table', $href);
3207         $sth  ||= $dbh->prepare($stmt);
3208         $sth->execute($sql->values($href));
3209     }
3210
3211 The reason this works is because the keys in your C<$href> are sorted
3212 internally by B<SQL::Abstract>. Thus, as long as your data retains
3213 the same structure, you only have to generate the SQL the first time
3214 around. On subsequent queries, simply use the C<values> function provided
3215 by this module to return your values in the correct order.
3216
3217 However this depends on the values having the same type - if, for
3218 example, the values of a where clause may either have values
3219 (resulting in sql of the form C<column = ?> with a single bind
3220 value), or alternatively the values might be C<undef> (resulting in
3221 sql of the form C<column IS NULL> with no bind value) then the
3222 caching technique suggested will not work.
3223
3224 =head1 FORMBUILDER
3225
3226 If you use my C<CGI::FormBuilder> module at all, you'll hopefully
3227 really like this part (I do, at least). Building up a complex query
3228 can be as simple as the following:
3229
3230     #!/usr/bin/perl
3231
3232     use warnings;
3233     use strict;
3234
3235     use CGI::FormBuilder;
3236     use SQL::Abstract;
3237
3238     my $form = CGI::FormBuilder->new(...);
3239     my $sql  = SQL::Abstract->new;
3240
3241     if ($form->submitted) {
3242         my $field = $form->field;
3243         my $id = delete $field->{id};
3244         my($stmt, @bind) = $sql->update('table', $field, {id => $id});
3245     }
3246
3247 Of course, you would still have to connect using C<DBI> to run the
3248 query, but the point is that if you make your form look like your
3249 table, the actual query script can be extremely simplistic.
3250
3251 If you're B<REALLY> lazy (I am), check out C<HTML::QuickTable> for
3252 a fast interface to returning and formatting data. I frequently
3253 use these three modules together to write complex database query
3254 apps in under 50 lines.
3255
3256 =head1 HOW TO CONTRIBUTE
3257
3258 Contributions are always welcome, in all usable forms (we especially
3259 welcome documentation improvements). The delivery methods include git-
3260 or unified-diff formatted patches, GitHub pull requests, or plain bug
3261 reports either via RT or the Mailing list. Contributors are generally
3262 granted full access to the official repository after their first several
3263 patches pass successful review.
3264
3265 This project is maintained in a git repository. The code and related tools are
3266 accessible at the following locations:
3267
3268 =over
3269
3270 =item * Official repo: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Abstract.git>
3271
3272 =item * Official gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/SQL-Abstract.git>
3273
3274 =item * GitHub mirror: L<https://github.com/dbsrgits/sql-abstract>
3275
3276 =item * Authorized committers: L<ssh://dbsrgits@git.shadowcat.co.uk/SQL-Abstract.git>
3277
3278 =back
3279
3280 =head1 CHANGES
3281
3282 Version 1.50 was a major internal refactoring of C<SQL::Abstract>.
3283 Great care has been taken to preserve the I<published> behavior
3284 documented in previous versions in the 1.* family; however,
3285 some features that were previously undocumented, or behaved
3286 differently from the documentation, had to be changed in order
3287 to clarify the semantics. Hence, client code that was relying
3288 on some dark areas of C<SQL::Abstract> v1.*
3289 B<might behave differently> in v1.50.
3290
3291 The main changes are:
3292
3293 =over
3294
3295 =item *
3296
3297 support for literal SQL through the C<< \ [ $sql, @bind ] >> syntax.
3298
3299 =item *
3300
3301 support for the { operator => \"..." } construct (to embed literal SQL)
3302
3303 =item *
3304
3305 support for the { operator => \["...", @bind] } construct (to embed literal SQL with bind values)
3306
3307 =item *
3308
3309 optional support for L<array datatypes|/"Inserting and Updating Arrays">
3310
3311 =item *
3312
3313 defensive programming: check arguments
3314
3315 =item *
3316
3317 fixed bug with global logic, which was previously implemented
3318 through global variables yielding side-effects. Prior versions would
3319 interpret C<< [ {cond1, cond2}, [cond3, cond4] ] >>
3320 as C<< "(cond1 AND cond2) OR (cond3 AND cond4)" >>.
3321 Now this is interpreted
3322 as C<< "(cond1 AND cond2) OR (cond3 OR cond4)" >>.
3323
3324
3325 =item *
3326
3327 fixed semantics of  _bindtype on array args
3328
3329 =item *
3330
3331 dropped the C<_anoncopy> of the %where tree. No longer necessary,
3332 we just avoid shifting arrays within that tree.
3333
3334 =item *
3335
3336 dropped the C<_modlogic> function
3337
3338 =back
3339
3340 =head1 ACKNOWLEDGEMENTS
3341
3342 There are a number of individuals that have really helped out with
3343 this module. Unfortunately, most of them submitted bugs via CPAN
3344 so I have no idea who they are! But the people I do know are:
3345
3346     Ash Berlin (order_by hash term support)
3347     Matt Trout (DBIx::Class support)
3348     Mark Stosberg (benchmarking)
3349     Chas Owens (initial "IN" operator support)
3350     Philip Collins (per-field SQL functions)
3351     Eric Kolve (hashref "AND" support)
3352     Mike Fragassi (enhancements to "BETWEEN" and "LIKE")
3353     Dan Kubb (support for "quote_char" and "name_sep")
3354     Guillermo Roditi (patch to cleanup "IN" and "BETWEEN", fix and tests for _order_by)
3355     Laurent Dami (internal refactoring, extensible list of special operators, literal SQL)
3356     Norbert Buchmuller (support for literal SQL in hashpair, misc. fixes & tests)
3357     Peter Rabbitson (rewrite of SQLA::Test, misc. fixes & tests)
3358     Oliver Charles (support for "RETURNING" after "INSERT")
3359
3360 Thanks!
3361
3362 =head1 SEE ALSO
3363
3364 L<DBIx::Class>, L<DBIx::Abstract>, L<CGI::FormBuilder>, L<HTML::QuickTable>.
3365
3366 =head1 AUTHOR
3367
3368 Copyright (c) 2001-2007 Nathan Wiger <nwiger@cpan.org>. All Rights Reserved.
3369
3370 This module is actively maintained by Matt Trout <mst@shadowcatsystems.co.uk>
3371
3372 For support, your best bet is to try the C<DBIx::Class> users mailing list.
3373 While not an official support venue, C<DBIx::Class> makes heavy use of
3374 C<SQL::Abstract>, and as such list members there are very familiar with
3375 how to create queries.
3376
3377 =head1 LICENSE
3378
3379 This module is free software; you may copy this under the same
3380 terms as perl itself (either the GNU General Public License or
3381 the Artistic License)
3382
3383 =cut