lib/SQL/Abstract.pm

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