lib/SQL/Abstract.pm

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