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