lib/SQL/Abstract.pm

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