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