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