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