lib/SQL/Abstract.pm

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