lib/SQL/Abstract.pm

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