lib/SQL/Abstract.pm

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