lib/SQL/Abstract.pm

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