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