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