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