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