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