lib/SQL/Abstract.pm

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