lib/SQL/Abstract.pm

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