lib/SQL/Abstract.pm

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