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