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