lib/SQL/Abstract.pm

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