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