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