lib/SQL/Abstract.pm

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