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