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