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