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