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