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