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