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