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