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