lib/SQL/Abstract.pm

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