lib/SQL/Abstract.pm

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