lib/SQL/Abstract.pm

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