lib/SQL/Abstract.pm

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