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