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