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