lib/SQL/Abstract.pm

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