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