lib/SQL/Abstract.pm

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