lib/SQL/Abstract.pm

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