lib/SQL/Abstract.pm

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