lib/SQL/Abstract.pm

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