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