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