lib/SQL/Abstract.pm

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