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