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