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