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