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