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