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