lib/SQL/Abstract.pm

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