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