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