lib/SQL/Abstract.pm

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