lib/SQL/Abstract.pm

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