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