lib/SQL/Abstract.pm

   1 package SQL::Abstract; # see doc at end of file
   2
   3 use strict;
   4 use warnings;
   5 use Module::Runtime ();
   6 use Carp ();
   7 use List::Util ();
   8 use Scalar::Util ();
   9
  10 use Exporter 'import';
  11 our @EXPORT_OK = qw(is_plain_value is_literal_value is_undef_value);
  12
  13 BEGIN {
  14   if ($] < 5.009_005) {
  15     require MRO::Compat;
  16   }
  17   else {
  18     require mro;
  19   }
  20
  21   *SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION = $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}
  22     ? sub () { 0 }
  23     : sub () { 1 }
  24   ;
  25 }
  26
  27 #======================================================================
  28 # GLOBALS
  29 #======================================================================
  30
  31 our $VERSION  = '1.90_02';
  32
  33 # This would confuse some packagers
  34 $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
  35
  36 our $AUTOLOAD;
  37
  38 # special operators (-in, -between). May be extended/overridden by user.
  39 # See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation
  40 my @BUILTIN_SPECIAL_OPS = (
  41   {regex => qr/^ (?: not \s )? between $/ix, handler => sub { die "NOPE" }},
  42   {regex => qr/^ is (?: \s+ not )?     $/ix, handler => sub { die "NOPE" }},
  43   {regex => qr/^ (?: not \s )? in      $/ix, handler => sub { die "NOPE" }},
  44   {regex => qr/^ ident                 $/ix, handler => sub { die "NOPE" }},
  45   {regex => qr/^ value                 $/ix, handler => sub { die "NOPE" }},
  46 );
  47
  48 #======================================================================
  49 # DEBUGGING AND ERROR REPORTING
  50 #======================================================================
  51
  52 sub _debug {
  53   return unless $_[0]->{debug}; shift; # a little faster
  54   my $func = (caller(1))[3];
  55   warn "[$func] ", @_, "\n";
  56 }
  57
  58 sub belch (@) {
  59   my($func) = (caller(1))[3];
  60   Carp::carp "[$func] Warning: ", @_;
  61 }
  62
  63 sub puke (@) {
  64   my($func) = (caller(1))[3];
  65   Carp::croak "[$func] Fatal: ", @_;
  66 }
  67
  68 sub is_literal_value ($) {
  69     ref $_[0] eq 'SCALAR'                                     ? [ ${$_[0]} ]
  70   : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' )        ? [ @${ $_[0] } ]
  71   : undef;
  72 }
  73
  74 sub is_undef_value ($) {
  75   !defined($_[0])
  76   or (
  77     ref($_[0]) eq 'HASH'
  78     and exists $_[0]->{-value}
  79     and not defined $_[0]->{-value}
  80   );
  81 }
  82
  83 # FIXME XSify - this can be done so much more efficiently
  84 sub is_plain_value ($) {
  85   no strict 'refs';
  86     ! length ref $_[0]                                        ? \($_[0])
  87   : (
  88     ref $_[0] eq 'HASH' and keys %{$_[0]} == 1
  89       and
  90     exists $_[0]->{-value}
  91   )                                                           ? \($_[0]->{-value})
  92   : (
  93       # reuse @_ for even moar speedz
  94       defined ( $_[1] = Scalar::Util::blessed $_[0] )
  95         and
  96       # deliberately not using Devel::OverloadInfo - the checks we are
  97       # intersted in are much more limited than the fullblown thing, and
  98       # this is a very hot piece of code
  99       (
 100         # simply using ->can('(""') can leave behind stub methods that
 101         # break actually using the overload later (see L<perldiag/Stub
 102         # found while resolving method "%s" overloading "%s" in package
 103         # "%s"> and the source of overload::mycan())
 104         #
 105         # either has stringification which DBI SHOULD prefer out of the box
 106         grep { *{ (qq[${_}::(""]) }{CODE} } @{ $_[2] = mro::get_linear_isa( $_[1] ) }
 107           or
 108         # has nummification or boolification, AND fallback is *not* disabled
 109         (
 110           SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION
 111             and
 112           (
 113             grep { *{"${_}::(0+"}{CODE} } @{$_[2]}
 114               or
 115             grep { *{"${_}::(bool"}{CODE} } @{$_[2]}
 116           )
 117             and
 118           (
 119             # no fallback specified at all
 120             ! ( ($_[3]) = grep { *{"${_}::()"}{CODE} } @{$_[2]} )
 121               or
 122             # fallback explicitly undef
 123             ! defined ${"$_[3]::()"}
 124               or
 125             # explicitly true
 126             !! ${"$_[3]::()"}
 127           )
 128         )
 129       )
 130     )                                                          ? \($_[0])
 131   : undef;
 132 }
 133
 134
 135
 136 #======================================================================
 137 # NEW
 138 #======================================================================
 139
 140 our %Defaults = (
 141   expand => {
 142     bool => '_expand_bool',
 143     row => '_expand_row',
 144     op => '_expand_op',
 145     func => '_expand_func',
 146     values => '_expand_values',
 147     list => '_expand_list',
 148   },
 149   expand_op => {
 150     (map +($_ => __PACKAGE__->make_binop_expander('_expand_between')),
 151       qw(between not_between)),
 152     (map +($_ => __PACKAGE__->make_binop_expander('_expand_in')),
 153       qw(in not_in)),
 154     (map +($_ => '_expand_op_andor'), ('and', 'or')),
 155     (map +($_ => '_expand_op_is'), ('is', 'is_not')),
 156     (map +($_ => __PACKAGE__->make_unop_expander("_expand_${_}")),
 157       qw(ident value nest)),
 158     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 @parts = map split(/\Q${\($self->{name_sep}||'.')}\E/, $_),
1288                 ref($body) ? @$body : $body;
1289   return { -ident => $parts[-1] } if $self->{_dequalify_idents};
1290   unless ($self->{quote_char}) {
1291     $self->_assert_pass_injection_guard($_) for @parts;
1292   }
1293   return +{ -ident => \@parts };
1294 }
1295
1296 sub _expand_value {
1297   +{ -bind => [ our $Cur_Col_Meta, $_[2] ] };
1298 }
1299
1300 sub _expand_row {
1301   my ($self, undef, $args) = @_;
1302   +{ -row => [ map $self->expand_expr($_), @$args ] };
1303 }
1304
1305 sub _expand_op {
1306   my ($self, undef, $args) = @_;
1307   my ($op, @opargs) = @$args;
1308   if (my $exp = $self->{expand_op}{$op}) {
1309     return $self->$exp($op, \@opargs);
1310   }
1311   if (List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
1312     return { -op => [ $op, @opargs ] };
1313   }
1314   +{ -op => [ $op, map $self->expand_expr($_), @opargs ] };
1315 }
1316
1317 sub _expand_bool {
1318   my ($self, undef, $v) = @_;
1319   if (ref($v)) {
1320     return $self->_expand_expr($v);
1321   }
1322   puke "-bool => undef not supported" unless defined($v);
1323   return $self->_expand_expr({ -ident => $v });
1324 }
1325
1326 sub _expand_list {
1327   my ($self, undef, $expr) = @_;
1328   return { -op => [
1329     ',', map $self->expand_expr($_),
1330           @{$expr->{-op}}[1..$#{$expr->{-op}}]
1331   ] } if ref($expr) eq 'HASH' and ($expr->{-op}||[''])->[0] eq ',';
1332   return +{ -op => [ ',',
1333     map $self->expand_expr($_),
1334       ref($expr) eq 'ARRAY' ? @$expr : $expr
1335   ] };
1336 }
1337
1338 sub _expand_logop {
1339   my ($self, $logop, $v, $k) = @_;
1340   $self->${\$self->{expand_op}{$logop}}($logop, $v, $k);
1341 }
1342
1343 sub _expand_op_andor {
1344   my ($self, $logop, $v, $k) = @_;
1345   if (defined $k) {
1346     $v = [ map +{ $k, $_ },
1347              (ref($v) eq 'HASH')
1348               ? (map +{ $_ => $v->{$_} }, sort keys %$v)
1349               : @$v,
1350          ];
1351   }
1352   if (ref($v) eq 'HASH') {
1353     return undef unless keys %$v;
1354     return +{ -op => [
1355       $logop,
1356       map $self->_expand_expr({ $_ => $v->{$_} }),
1357         sort keys %$v
1358     ] };
1359   }
1360   if (ref($v) eq 'ARRAY') {
1361     $logop eq 'and' or $logop eq 'or' or puke "unknown logic: $logop";
1362
1363     my @expr = grep {
1364       (ref($_) eq 'ARRAY' and @$_)
1365       or (ref($_) eq 'HASH' and %$_)
1366       or 1
1367     } @$v;
1368
1369     my @res;
1370
1371     while (my ($el) = splice @expr, 0, 1) {
1372       puke "Supplying an empty left hand side argument is not supported in array-pairs"
1373         unless defined($el) and length($el);
1374       my $elref = ref($el);
1375       if (!$elref) {
1376         local our $Expand_Depth = 0;
1377         push(@res, grep defined, $self->_expand_expr({ $el, shift(@expr) }));
1378       } elsif ($elref eq 'ARRAY') {
1379         push(@res, grep defined, $self->_expand_expr($el)) if @$el;
1380       } elsif (my $l = is_literal_value($el)) {
1381         push @res, { -literal => $l };
1382       } elsif ($elref eq 'HASH') {
1383         local our $Expand_Depth = 0;
1384         push @res, grep defined, $self->_expand_expr($el) if %$el;
1385       } else {
1386         die "notreached";
1387       }
1388     }
1389     # ???
1390     # return $res[0] if @res == 1;
1391     return { -op => [ $logop, @res ] };
1392   }
1393   die "notreached";
1394 }
1395
1396 sub _expand_op_is {
1397   my ($self, $op, $vv, $k) = @_;
1398   ($k, $vv) = @$vv unless defined $k;
1399   puke "$op can only take undef as argument"
1400     if defined($vv)
1401        and not (
1402          ref($vv) eq 'HASH'
1403          and exists($vv->{-value})
1404          and !defined($vv->{-value})
1405        );
1406   return +{ -op => [ $op.'_null', $self->expand_expr($k, -ident) ] };
1407 }
1408
1409 sub _expand_between {
1410   my ($self, $op, $vv, $k) = @_;
1411   my @rhs = map $self->_expand_expr($_),
1412               ref($vv) eq 'ARRAY' ? @$vv : $vv;
1413   unless (
1414     (@rhs == 1 and ref($rhs[0]) eq 'HASH' and $rhs[0]->{-literal})
1415     or
1416     (@rhs == 2 and defined($rhs[0]) and defined($rhs[1]))
1417   ) {
1418     puke "Operator '${\uc($op)}' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref";
1419   }
1420   return +{ -op => [
1421     $op,
1422     $self->expand_expr($k),
1423     map $self->expand_expr($_, -value), @rhs
1424   ] }
1425 }
1426
1427 sub _expand_in {
1428   my ($self, $op, $vv, $k) = @_;
1429   if (my $literal = is_literal_value($vv)) {
1430     my ($sql, @bind) = @$literal;
1431     my $opened_sql = $self->_open_outer_paren($sql);
1432     return +{ -op => [
1433       $op, $self->expand_expr($k, -ident),
1434       { -literal => [ $opened_sql, @bind ] }
1435     ] };
1436   }
1437   my $undef_err =
1438     'SQL::Abstract before v1.75 used to generate incorrect SQL when the '
1439   . "-${\uc($op)} operator was given an undef-containing list: !!!AUDIT YOUR CODE "
1440   . 'AND DATA!!! (the upcoming Data::Query-based version of SQL::Abstract '
1441   . 'will emit the logically correct SQL instead of raising this exception)'
1442   ;
1443   puke("Argument passed to the '${\uc($op)}' operator can not be undefined")
1444     if !defined($vv);
1445   my @rhs = map $self->expand_expr($_, -value),
1446               map { defined($_) ? $_: puke($undef_err) }
1447                 (ref($vv) eq 'ARRAY' ? @$vv : $vv);
1448   return $self->${\($op =~ /^not/ ? 'sqltrue' : 'sqlfalse')} unless @rhs;
1449
1450   return +{ -op => [
1451     $op,
1452     $self->expand_expr($k, -ident),
1453     @rhs
1454   ] };
1455 }
1456
1457 sub _expand_nest {
1458   my ($self, undef, $v) = @_;
1459   # DBIx::Class requires a nest warning to be emitted once but the private
1460   # method it overrode to do so no longer exists
1461   if ($self->{warn_once_on_nest}) {
1462     unless (our $Nest_Warned) {
1463       belch(
1464         "-nest in search conditions is deprecated, you most probably wanted:\n"
1465         .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
1466       );
1467       $Nest_Warned = 1;
1468     }
1469   }
1470   return $self->_expand_expr($v);
1471 }
1472
1473 sub _expand_values {
1474   my ($self, undef, $values) = @_;
1475   return { -values => [
1476     map +(
1477       ref($_) eq 'HASH'
1478         ? $self->expand_expr($_)
1479         : +{ -row => [ map $self->expand_expr($_), @$_ ] }
1480     ), ref($values) eq 'ARRAY' ? @$values : $values
1481   ] };
1482 }
1483
1484 sub _recurse_where {
1485   my ($self, $where) = @_;
1486
1487   # Special case: top level simple string treated as literal
1488
1489   my $where_exp = (ref($where)
1490                     ? $self->_expand_select_clause_where(undef, $where)
1491                     : { -literal => [ $where ] });
1492
1493   # dispatch expanded expression
1494
1495   my ($sql, @bind) = defined($where_exp) ? @{ $self->render_aqt($where_exp) || [] } : ();
1496   # DBIx::Class used to call _recurse_where in scalar context
1497   # something else might too...
1498   if (wantarray) {
1499     return ($sql, @bind);
1500   }
1501   else {
1502     belch "Calling _recurse_where in scalar context is deprecated and will go away before 2.0";
1503     return $sql;
1504   }
1505 }
1506
1507 sub _render_ident {
1508   my ($self, undef, $ident) = @_;
1509
1510   return [ $self->_quote($ident) ];
1511 }
1512
1513 sub _render_row {
1514   my ($self, undef, $values) = @_;
1515   return $self->join_query_parts('',
1516     '(',
1517     $self->_render_op(undef, [ ',', @$values ]),
1518     ')'
1519   );
1520 }
1521
1522 sub _render_func {
1523   my ($self, undef, $rest) = @_;
1524   my ($func, @args) = @$rest;
1525   return $self->join_query_parts('',
1526     $self->_sqlcase($func),
1527     $self->join_query_parts('',
1528       '(',
1529       $self->join_query_parts(', ', @args),
1530       ')'
1531     ),
1532   );
1533 }
1534
1535 sub _render_bind {
1536   my ($self, undef, $bind) = @_;
1537   return [ '?', $self->_bindtype(@$bind) ];
1538 }
1539
1540 sub _render_literal {
1541   my ($self, undef, $literal) = @_;
1542   $self->_assert_bindval_matches_bindtype(@{$literal}[1..$#$literal]);
1543   return $literal;
1544 }
1545
1546 sub _render_keyword {
1547   my ($self, undef, $keyword) = @_;
1548   return [ $self->_sqlcase(
1549     ref($keyword) ? $$keyword : join ' ', split '_', $keyword
1550   ) ];
1551 }
1552
1553 sub _render_op {
1554   my ($self, undef, $v) = @_;
1555   my ($op, @args) = @$v;
1556   if (my $r = $self->{render_op}{$op}) {
1557     return $self->$r($op, \@args);
1558   }
1559
1560   { # Old SQLA compat
1561
1562     my $op = join(' ', split '_', $op);
1563
1564     my $ss = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
1565     if ($ss and @args > 1) {
1566       puke "Special op '${op}' requires first value to be identifier"
1567         unless my ($ident) = map $_->{-ident}, grep ref($_) eq 'HASH', $args[0];
1568       my $k = join(($self->{name_sep}||'.'), @$ident);
1569       local our $Expand_Depth = 1;
1570       return [ $self->${\($ss->{handler})}($k, $op, $args[1]) ];
1571     }
1572     if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
1573       return [ $self->${\($us->{handler})}($op, $args[0]) ];
1574     }
1575     if ($ss) {
1576       return $self->_render_unop_paren($op, \@args);
1577     }
1578   }
1579   if (@args == 1) {
1580     return $self->_render_unop_prefix($op, \@args);
1581   } else {
1582     return $self->_render_op_multop($op, \@args);
1583   }
1584   die "notreached";
1585 }
1586
1587
1588 sub _render_op_between {
1589   my ($self, $op, $args) = @_;
1590   my ($left, $low, $high) = @$args;
1591   my @rh = do {
1592     if (@$args == 2) {
1593       puke "Single arg to between must be a literal"
1594         unless $low->{-literal};
1595       $low;
1596     } else {
1597       +($low, { -keyword => 'and' }, $high);
1598     }
1599   };
1600   return $self->join_query_parts(' ',
1601     '(', $left, { -keyword => $op }, @rh, ')',
1602   );
1603 }
1604
1605 sub _render_op_in {
1606   my ($self, $op, $args) = @_;
1607   my ($lhs, @rhs) = @$args;
1608
1609   return $self->join_query_parts(' ',
1610     $lhs,
1611     { -keyword => $op },
1612     $self->join_query_parts(' ',
1613       '(',
1614       $self->join_query_parts(', ', @rhs),
1615       ')'
1616     ),
1617   );
1618 }
1619
1620 sub _render_op_andor {
1621   my ($self, $op, $args) = @_;
1622   return undef unless @$args;
1623   return $self->join_query_parts('', $args->[0]) if @$args == 1;
1624   my $inner = $self->_render_op_multop($op, $args);
1625   return undef unless defined($inner->[0]) and length($inner->[0]);
1626   return $self->join_query_parts(' ',
1627     '(', $inner, ')'
1628   );
1629 }
1630
1631 sub _render_op_multop {
1632   my ($self, $op, $args) = @_;
1633   my @parts = @$args;
1634   return undef unless @parts;
1635   return $self->render_aqt($parts[0]) if @parts == 1;
1636   my $join = ($op eq ','
1637                 ? ', '
1638                 : { -keyword => " ${op} " }
1639              );
1640   return $self->join_query_parts($join, @parts);
1641 }
1642
1643 sub _render_values {
1644   my ($self, undef, $values) = @_;
1645   my $inner = $self->join_query_parts(' ',
1646     { -keyword => 'values' },
1647     $self->join_query_parts(', ',
1648       ref($values) eq 'ARRAY' ? @$values : $values
1649     ),
1650   );
1651   return $self->join_query_parts('',
1652     (our $Render_Top_Level ? $inner : ('(', $inner, ')'))
1653   );
1654 }
1655
1656 sub join_query_parts {
1657   my ($self, $join, @parts) = @_;
1658   if (ref($join) eq 'HASH') {
1659     $join = $self->render_aqt($join)->[0];
1660   }
1661   my @final = map +(
1662     ref($_) eq 'HASH'
1663       ? $self->render_aqt($_)
1664       : ((ref($_) eq 'ARRAY') ? $_ : [ $_ ])
1665   ), @parts;
1666   return [
1667     $self->{join_sql_parts}->(
1668       $join, grep defined && length, map $_->[0], @final
1669     ),
1670     (map @{$_}[1..$#$_], @final),
1671   ];
1672 }
1673
1674 sub _render_unop_paren {
1675   my ($self, $op, $v) = @_;
1676   return $self->join_query_parts('',
1677     '(', $self->_render_unop_prefix($op, $v), ')'
1678   );
1679 }
1680
1681 sub _render_unop_prefix {
1682   my ($self, $op, $v) = @_;
1683   my $op_sql = $self->{restore_old_unop_handling}
1684                  ? $self->_sqlcase($op)
1685                  : { -keyword => $op };
1686   return $self->join_query_parts(' ',
1687     ($self->{restore_old_unop_handling}
1688       ? $self->_sqlcase($op)
1689       : { -keyword => \$op }),
1690     $v->[0]
1691   );
1692 }
1693
1694 sub _render_unop_postfix {
1695   my ($self, $op, $v) = @_;
1696   return $self->join_query_parts(' ',
1697     $v->[0], { -keyword => $op },
1698   );
1699 }
1700
1701 # Some databases (SQLite) treat col IN (1, 2) different from
1702 # col IN ( (1, 2) ). Use this to strip all outer parens while
1703 # adding them back in the corresponding method
1704 sub _open_outer_paren {
1705   my ($self, $sql) = @_;
1706
1707   while (my ($inner) = $sql =~ /^ \s* \( (.*) \) \s* $/xs) {
1708
1709     # there are closing parens inside, need the heavy duty machinery
1710     # to reevaluate the extraction starting from $sql (full reevaluation)
1711     if ($inner =~ /\)/) {
1712       require Text::Balanced;
1713
1714       my (undef, $remainder) = do {
1715         # idiotic design - writes to $@ but *DOES NOT* throw exceptions
1716         local $@;
1717         Text::Balanced::extract_bracketed($sql, '()', qr/\s*/);
1718       };
1719
1720       # the entire expression needs to be a balanced bracketed thing
1721       # (after an extract no remainder sans trailing space)
1722       last if defined $remainder and $remainder =~ /\S/;
1723     }
1724
1725     $sql = $inner;
1726   }
1727
1728   $sql;
1729 }
1730
1731 sub _where_field_IN {
1732   my ($self, $k, $op, $vals) = @_;
1733   @{$self->_render_op_in(
1734     $op,
1735     [
1736       $self->expand_expr($k, -ident),
1737       map $self->expand_expr($_, -value),
1738         ref($vals) eq 'ARRAY' ? @$vals : $vals
1739     ]
1740   )};
1741 }
1742
1743 sub _where_field_BETWEEN {
1744   my ($self, $k, $op, $vals) = @_;
1745   @{$self->_render_op_between(
1746     $op,
1747     [ $self->expand_expr($k, -ident), ref($vals) eq 'ARRAY' ? @$vals : $vals ]
1748   )};
1749 }
1750
1751 #======================================================================
1752 # ORDER BY
1753 #======================================================================
1754
1755 sub _expand_order_by {
1756   my ($self, $arg) = @_;
1757
1758   return unless defined($arg) and not (ref($arg) eq 'ARRAY' and !@$arg);
1759
1760   return $self->expand_expr({ -list => $arg })
1761     if ref($arg) eq 'HASH' and ($arg->{-op}||[''])->[0] eq ',';
1762
1763   my $expander = sub {
1764     my ($self, $dir, $expr) = @_;
1765     my @to_expand = ref($expr) eq 'ARRAY' ? @$expr : $expr;
1766     foreach my $arg (@to_expand) {
1767       if (
1768         ref($arg) eq 'HASH'
1769         and keys %$arg > 1
1770         and grep /^-(asc|desc)$/, keys %$arg
1771       ) {
1772         puke "ordering direction hash passed to order by must have exactly one key (-asc or -desc)";
1773       }
1774     }
1775     my @exp = map +(
1776                 defined($dir) ? { -op => [ $dir =~ /^-?(.*)$/ ,=> $_ ] } : $_
1777               ),
1778                 map $self->expand_expr($_, -ident),
1779                 map ref($_) eq 'ARRAY' ? @$_ : $_, @to_expand;
1780     return undef unless @exp;
1781     return undef if @exp == 1 and not defined($exp[0]);
1782     return +{ -op => [ ',', @exp ] };
1783   };
1784
1785   local @{$self->{expand}}{qw(asc desc)} = (($expander) x 2);
1786
1787   return $self->$expander(undef, $arg);
1788 }
1789
1790 sub _order_by {
1791   my ($self, $arg) = @_;
1792
1793   return '' unless defined(my $expanded = $self->_expand_order_by($arg));
1794
1795   my ($sql, @bind) = @{ $self->render_aqt($expanded) };
1796
1797   return '' unless length($sql);
1798
1799   my $final_sql = $self->_sqlcase(' order by ').$sql;
1800
1801   return $final_sql unless wantarray;
1802
1803   return ($final_sql, @bind);
1804 }
1805
1806 # _order_by no longer needs to call this so doesn't but DBIC uses it.
1807
1808 sub _order_by_chunks {
1809   my ($self, $arg) = @_;
1810
1811   return () unless defined(my $expanded = $self->_expand_order_by($arg));
1812
1813   my @res = $self->_chunkify_order_by($expanded);
1814   (ref() ? $_->[0] : $_) .= '' for @res;
1815   return @res;
1816 }
1817
1818 sub _chunkify_order_by {
1819   my ($self, $expanded) = @_;
1820
1821   return grep length, @{ $self->render_aqt($expanded) }
1822     if $expanded->{-ident} or @{$expanded->{-literal}||[]} == 1;
1823
1824   for ($expanded) {
1825     if (ref() eq 'HASH' and $_->{-op} and $_->{-op}[0] eq ',') {
1826       my ($comma, @list) = @{$_->{-op}};
1827       return map $self->_chunkify_order_by($_), @list;
1828     }
1829     return $self->render_aqt($_);
1830   }
1831 }
1832
1833 #======================================================================
1834 # DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
1835 #======================================================================
1836
1837 sub _table  {
1838   my $self = shift;
1839   my $from = shift;
1840   $self->render_aqt(
1841     $self->expand_expr({ -list => $from }, -ident)
1842   )->[0];
1843 }
1844
1845
1846 #======================================================================
1847 # UTILITY FUNCTIONS
1848 #======================================================================
1849
1850 # highly optimized, as it's called way too often
1851 sub _quote {
1852   # my ($self, $label) = @_;
1853
1854   return '' unless defined $_[1];
1855   return ${$_[1]} if ref($_[1]) eq 'SCALAR';
1856   puke 'Identifier cannot be hashref' if ref($_[1]) eq 'HASH';
1857
1858   unless ($_[0]->{quote_char}) {
1859     if (ref($_[1]) eq 'ARRAY') {
1860       return join($_[0]->{name_sep}||'.', @{$_[1]});
1861     } else {
1862       $_[0]->_assert_pass_injection_guard($_[1]);
1863       return $_[1];
1864     }
1865   }
1866
1867   my $qref = ref $_[0]->{quote_char};
1868   my ($l, $r) =
1869       !$qref             ? ($_[0]->{quote_char}, $_[0]->{quote_char})
1870     : ($qref eq 'ARRAY') ? @{$_[0]->{quote_char}}
1871     : puke "Unsupported quote_char format: $_[0]->{quote_char}";
1872
1873   my $esc = $_[0]->{escape_char} || $r;
1874
1875   # parts containing * are naturally unquoted
1876   return join(
1877     $_[0]->{name_sep}||'',
1878     map +(
1879       $_ eq '*'
1880         ? $_
1881         : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r }
1882     ),
1883     (ref($_[1]) eq 'ARRAY'
1884       ? @{$_[1]}
1885       : (
1886           $_[0]->{name_sep}
1887             ? split (/\Q$_[0]->{name_sep}\E/, $_[1] )
1888             : $_[1]
1889         )
1890     )
1891   );
1892 }
1893
1894
1895 # Conversion, if applicable
1896 sub _convert {
1897   #my ($self, $arg) = @_;
1898   if (my $conv = $_[0]->{convert_where}) {
1899     return @{ $_[0]->join_query_parts('',
1900       $_[0]->_sqlcase($conv),
1901       '(' , $_[1] , ')'
1902     ) };
1903   }
1904   return $_[1];
1905 }
1906
1907 # And bindtype
1908 sub _bindtype {
1909   #my ($self, $col, @vals) = @_;
1910   # called often - tighten code
1911   return $_[0]->{bindtype} eq 'columns'
1912     ? map {[$_[1], $_]} @_[2 .. $#_]
1913     : @_[2 .. $#_]
1914   ;
1915 }
1916
1917 # Dies if any element of @bind is not in [colname => value] format
1918 # if bindtype is 'columns'.
1919 sub _assert_bindval_matches_bindtype {
1920 #  my ($self, @bind) = @_;
1921   my $self = shift;
1922   if ($self->{bindtype} eq 'columns') {
1923     for (@_) {
1924       if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
1925         puke "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
1926       }
1927     }
1928   }
1929 }
1930
1931 # Fix SQL case, if so requested
1932 sub _sqlcase {
1933   # LDNOTE: if $self->{case} is true, then it contains 'lower', so we
1934   # don't touch the argument ... crooked logic, but let's not change it!
1935   return $_[0]->{case} ? $_[1] : uc($_[1]);
1936 }
1937
1938 #======================================================================
1939 # DISPATCHING FROM REFKIND
1940 #======================================================================
1941
1942 sub _refkind {
1943   my ($self, $data) = @_;
1944
1945   return 'UNDEF' unless defined $data;
1946
1947   # blessed objects are treated like scalars
1948   my $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
1949
1950   return 'SCALAR' unless $ref;
1951
1952   my $n_steps = 1;
1953   while ($ref eq 'REF') {
1954     $data = $$data;
1955     $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
1956     $n_steps++ if $ref;
1957   }
1958
1959   return ($ref||'SCALAR') . ('REF' x $n_steps);
1960 }
1961
1962 sub _try_refkind {
1963   my ($self, $data) = @_;
1964   my @try = ($self->_refkind($data));
1965   push @try, 'SCALAR_or_UNDEF' if $try[0] eq 'SCALAR' || $try[0] eq 'UNDEF';
1966   push @try, 'FALLBACK';
1967   return \@try;
1968 }
1969
1970 sub _METHOD_FOR_refkind {
1971   my ($self, $meth_prefix, $data) = @_;
1972
1973   my $method;
1974   for (@{$self->_try_refkind($data)}) {
1975     $method = $self->can($meth_prefix."_".$_)
1976       and last;
1977   }
1978
1979   return $method || puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data);
1980 }
1981
1982
1983 sub _SWITCH_refkind {
1984   my ($self, $data, $dispatch_table) = @_;
1985
1986   my $coderef;
1987   for (@{$self->_try_refkind($data)}) {
1988     $coderef = $dispatch_table->{$_}
1989       and last;
1990   }
1991
1992   puke "no dispatch entry for ".$self->_refkind($data)
1993     unless $coderef;
1994
1995   $coderef->();
1996 }
1997
1998
1999
2000
2001 #======================================================================
2002 # VALUES, GENERATE, AUTOLOAD
2003 #======================================================================
2004
2005 # LDNOTE: original code from nwiger, didn't touch code in that section
2006 # I feel the AUTOLOAD stuff should not be the default, it should
2007 # only be activated on explicit demand by user.
2008
2009 sub values {
2010     my $self = shift;
2011     my $data = shift || return;
2012     puke "Argument to ", __PACKAGE__, "->values must be a \\%hash"
2013         unless ref $data eq 'HASH';
2014
2015     my @all_bind;
2016     foreach my $k (sort keys %$data) {
2017         my $v = $data->{$k};
2018         $self->_SWITCH_refkind($v, {
2019           ARRAYREF => sub {
2020             if ($self->{array_datatypes}) { # array datatype
2021               push @all_bind, $self->_bindtype($k, $v);
2022             }
2023             else {                          # literal SQL with bind
2024               my ($sql, @bind) = @$v;
2025               $self->_assert_bindval_matches_bindtype(@bind);
2026               push @all_bind, @bind;
2027             }
2028           },
2029           ARRAYREFREF => sub { # literal SQL with bind
2030             my ($sql, @bind) = @${$v};
2031             $self->_assert_bindval_matches_bindtype(@bind);
2032             push @all_bind, @bind;
2033           },
2034           SCALARREF => sub {  # literal SQL without bind
2035           },
2036           SCALAR_or_UNDEF => sub {
2037             push @all_bind, $self->_bindtype($k, $v);
2038           },
2039         });
2040     }
2041
2042     return @all_bind;
2043 }
2044
2045 sub generate {
2046     my $self  = shift;
2047
2048     my(@sql, @sqlq, @sqlv);
2049
2050     for (@_) {
2051         my $ref = ref $_;
2052         if ($ref eq 'HASH') {
2053             for my $k (sort keys %$_) {
2054                 my $v = $_->{$k};
2055                 my $r = ref $v;
2056                 my $label = $self->_quote($k);
2057                 if ($r eq 'ARRAY') {
2058                     # literal SQL with bind
2059                     my ($sql, @bind) = @$v;
2060                     $self->_assert_bindval_matches_bindtype(@bind);
2061                     push @sqlq, "$label = $sql";
2062                     push @sqlv, @bind;
2063                 } elsif ($r eq 'SCALAR') {
2064                     # literal SQL without bind
2065                     push @sqlq, "$label = $$v";
2066                 } else {
2067                     push @sqlq, "$label = ?";
2068                     push @sqlv, $self->_bindtype($k, $v);
2069                 }
2070             }
2071             push @sql, $self->_sqlcase('set'), join ', ', @sqlq;
2072         } elsif ($ref eq 'ARRAY') {
2073             # unlike insert(), assume these are ONLY the column names, i.e. for SQL
2074             for my $v (@$_) {
2075                 my $r = ref $v;
2076                 if ($r eq 'ARRAY') {   # literal SQL with bind
2077                     my ($sql, @bind) = @$v;
2078                     $self->_assert_bindval_matches_bindtype(@bind);
2079                     push @sqlq, $sql;
2080                     push @sqlv, @bind;
2081                 } elsif ($r eq 'SCALAR') {  # literal SQL without bind
2082                     # embedded literal SQL
2083                     push @sqlq, $$v;
2084                 } else {
2085                     push @sqlq, '?';
2086                     push @sqlv, $v;
2087                 }
2088             }
2089             push @sql, '(' . join(', ', @sqlq) . ')';
2090         } elsif ($ref eq 'SCALAR') {
2091             # literal SQL
2092             push @sql, $$_;
2093         } else {
2094             # strings get case twiddled
2095             push @sql, $self->_sqlcase($_);
2096         }
2097     }
2098
2099     my $sql = join ' ', @sql;
2100
2101     # this is pretty tricky
2102     # if ask for an array, return ($stmt, @bind)
2103     # otherwise, s/?/shift @sqlv/ to put it inline
2104     if (wantarray) {
2105         return ($sql, @sqlv);
2106     } else {
2107         1 while $sql =~ s/\?/my $d = shift(@sqlv);
2108                              ref $d ? $d->[1] : $d/e;
2109         return $sql;
2110     }
2111 }
2112
2113
2114 sub DESTROY { 1 }
2115
2116 sub AUTOLOAD {
2117     # This allows us to check for a local, then _form, attr
2118     my $self = shift;
2119     my($name) = $AUTOLOAD =~ /.*::(.+)/;
2120     puke "AUTOLOAD invoked for method name ${name} and allow_autoload option not set" unless $self->{allow_autoload};
2121     return $self->generate($name, @_);
2122 }
2123
2124 1;
2125
2126
2127
2128 __END__
2129
2130 =head1 NAME
2131
2132 SQL::Abstract - Generate SQL from Perl data structures
2133
2134 =head1 SYNOPSIS
2135
2136     use SQL::Abstract;
2137
2138     my $sql = SQL::Abstract->new;
2139
2140     my($stmt, @bind) = $sql->select($source, \@fields, \%where, $order);
2141
2142     my($stmt, @bind) = $sql->insert($table, \%fieldvals || \@values);
2143
2144     my($stmt, @bind) = $sql->update($table, \%fieldvals, \%where);
2145
2146     my($stmt, @bind) = $sql->delete($table, \%where);
2147
2148     # Then, use these in your DBI statements
2149     my $sth = $dbh->prepare($stmt);
2150     $sth->execute(@bind);
2151
2152     # Just generate the WHERE clause
2153     my($stmt, @bind) = $sql->where(\%where, $order);
2154
2155     # Return values in the same order, for hashed queries
2156     # See PERFORMANCE section for more details
2157     my @bind = $sql->values(\%fieldvals);
2158
2159 =head1 DESCRIPTION
2160
2161 This module was inspired by the excellent L<DBIx::Abstract>.
2162 However, in using that module I found that what I really wanted
2163 to do was generate SQL, but still retain complete control over my
2164 statement handles and use the DBI interface. So, I set out to
2165 create an abstract SQL generation module.
2166
2167 While based on the concepts used by L<DBIx::Abstract>, there are
2168 several important differences, especially when it comes to WHERE
2169 clauses. I have modified the concepts used to make the SQL easier
2170 to generate from Perl data structures and, IMO, more intuitive.
2171 The underlying idea is for this module to do what you mean, based
2172 on the data structures you provide it. The big advantage is that
2173 you don't have to modify your code every time your data changes,
2174 as this module figures it out.
2175
2176 To begin with, an SQL INSERT is as easy as just specifying a hash
2177 of C<key=value> pairs:
2178
2179     my %data = (
2180         name => 'Jimbo Bobson',
2181         phone => '123-456-7890',
2182         address => '42 Sister Lane',
2183         city => 'St. Louis',
2184         state => 'Louisiana',
2185     );
2186
2187 The SQL can then be generated with this:
2188
2189     my($stmt, @bind) = $sql->insert('people', \%data);
2190
2191 Which would give you something like this:
2192
2193     $stmt = "INSERT INTO people
2194                     (address, city, name, phone, state)
2195                     VALUES (?, ?, ?, ?, ?)";
2196     @bind = ('42 Sister Lane', 'St. Louis', 'Jimbo Bobson',
2197              '123-456-7890', 'Louisiana');
2198
2199 These are then used directly in your DBI code:
2200
2201     my $sth = $dbh->prepare($stmt);
2202     $sth->execute(@bind);
2203
2204 =head2 Inserting and Updating Arrays
2205
2206 If your database has array types (like for example Postgres),
2207 activate the special option C<< array_datatypes => 1 >>
2208 when creating the C<SQL::Abstract> object.
2209 Then you may use an arrayref to insert and update database array types:
2210
2211     my $sql = SQL::Abstract->new(array_datatypes => 1);
2212     my %data = (
2213         planets => [qw/Mercury Venus Earth Mars/]
2214     );
2215
2216     my($stmt, @bind) = $sql->insert('solar_system', \%data);
2217
2218 This results in:
2219
2220     $stmt = "INSERT INTO solar_system (planets) VALUES (?)"
2221
2222     @bind = (['Mercury', 'Venus', 'Earth', 'Mars']);
2223
2224
2225 =head2 Inserting and Updating SQL
2226
2227 In order to apply SQL functions to elements of your C<%data> you may
2228 specify a reference to an arrayref for the given hash value. For example,
2229 if you need to execute the Oracle C<to_date> function on a value, you can
2230 say something like this:
2231
2232     my %data = (
2233         name => 'Bill',
2234         date_entered => \[ "to_date(?,'MM/DD/YYYY')", "03/02/2003" ],
2235     );
2236
2237 The first value in the array is the actual SQL. Any other values are
2238 optional and would be included in the bind values array. This gives
2239 you:
2240
2241     my($stmt, @bind) = $sql->insert('people', \%data);
2242
2243     $stmt = "INSERT INTO people (name, date_entered)
2244                 VALUES (?, to_date(?,'MM/DD/YYYY'))";
2245     @bind = ('Bill', '03/02/2003');
2246
2247 An UPDATE is just as easy, all you change is the name of the function:
2248
2249     my($stmt, @bind) = $sql->update('people', \%data);
2250
2251 Notice that your C<%data> isn't touched; the module will generate
2252 the appropriately quirky SQL for you automatically. Usually you'll
2253 want to specify a WHERE clause for your UPDATE, though, which is
2254 where handling C<%where> hashes comes in handy...
2255
2256 =head2 Complex where statements
2257
2258 This module can generate pretty complicated WHERE statements
2259 easily. For example, simple C<key=value> pairs are taken to mean
2260 equality, and if you want to see if a field is within a set
2261 of values, you can use an arrayref. Let's say we wanted to
2262 SELECT some data based on this criteria:
2263
2264     my %where = (
2265        requestor => 'inna',
2266        worker => ['nwiger', 'rcwe', 'sfz'],
2267        status => { '!=', 'completed' }
2268     );
2269
2270     my($stmt, @bind) = $sql->select('tickets', '*', \%where);
2271
2272 The above would give you something like this:
2273
2274     $stmt = "SELECT * FROM tickets WHERE
2275                 ( requestor = ? ) AND ( status != ? )
2276                 AND ( worker = ? OR worker = ? OR worker = ? )";
2277     @bind = ('inna', 'completed', 'nwiger', 'rcwe', 'sfz');
2278
2279 Which you could then use in DBI code like so:
2280
2281     my $sth = $dbh->prepare($stmt);
2282     $sth->execute(@bind);
2283
2284 Easy, eh?
2285
2286 =head1 METHODS
2287
2288 The methods are simple. There's one for every major SQL operation,
2289 and a constructor you use first. The arguments are specified in a
2290 similar order for each method (table, then fields, then a where
2291 clause) to try and simplify things.
2292
2293 =head2 new(option => 'value')
2294
2295 The C<new()> function takes a list of options and values, and returns
2296 a new B<SQL::Abstract> object which can then be used to generate SQL
2297 through the methods below. The options accepted are:
2298
2299 =over
2300
2301 =item case
2302
2303 If set to 'lower', then SQL will be generated in all lowercase. By
2304 default SQL is generated in "textbook" case meaning something like:
2305
2306     SELECT a_field FROM a_table WHERE some_field LIKE '%someval%'
2307
2308 Any setting other than 'lower' is ignored.
2309
2310 =item cmp
2311
2312 This determines what the default comparison operator is. By default
2313 it is C<=>, meaning that a hash like this:
2314
2315     %where = (name => 'nwiger', email => 'nate@wiger.org');
2316
2317 Will generate SQL like this:
2318
2319     WHERE name = 'nwiger' AND email = 'nate@wiger.org'
2320
2321 However, you may want loose comparisons by default, so if you set
2322 C<cmp> to C<like> you would get SQL such as:
2323
2324     WHERE name like 'nwiger' AND email like 'nate@wiger.org'
2325
2326 You can also override the comparison on an individual basis - see
2327 the huge section on L</"WHERE CLAUSES"> at the bottom.
2328
2329 =item sqltrue, sqlfalse
2330
2331 Expressions for inserting boolean values within SQL statements.
2332 By default these are C<1=1> and C<1=0>. They are used
2333 by the special operators C<-in> and C<-not_in> for generating
2334 correct SQL even when the argument is an empty array (see below).
2335
2336 =item logic
2337
2338 This determines the default logical operator for multiple WHERE
2339 statements in arrays or hashes. If absent, the default logic is "or"
2340 for arrays, and "and" for hashes. This means that a WHERE
2341 array of the form:
2342
2343     @where = (
2344         event_date => {'>=', '2/13/99'},
2345         event_date => {'<=', '4/24/03'},
2346     );
2347
2348 will generate SQL like this:
2349
2350     WHERE event_date >= '2/13/99' OR event_date <= '4/24/03'
2351
2352 This is probably not what you want given this query, though (look
2353 at the dates). To change the "OR" to an "AND", simply specify:
2354
2355     my $sql = SQL::Abstract->new(logic => 'and');
2356
2357 Which will change the above C<WHERE> to:
2358
2359     WHERE event_date >= '2/13/99' AND event_date <= '4/24/03'
2360
2361 The logic can also be changed locally by inserting
2362 a modifier in front of an arrayref:
2363
2364     @where = (-and => [event_date => {'>=', '2/13/99'},
2365                        event_date => {'<=', '4/24/03'} ]);
2366
2367 See the L</"WHERE CLAUSES"> section for explanations.
2368
2369 =item convert
2370
2371 This will automatically convert comparisons using the specified SQL
2372 function for both column and value. This is mostly used with an argument
2373 of C<upper> or C<lower>, so that the SQL will have the effect of
2374 case-insensitive "searches". For example, this:
2375
2376     $sql = SQL::Abstract->new(convert => 'upper');
2377     %where = (keywords => 'MaKe iT CAse inSeNSItive');
2378
2379 Will turn out the following SQL:
2380
2381     WHERE upper(keywords) like upper('MaKe iT CAse inSeNSItive')
2382
2383 The conversion can be C<upper()>, C<lower()>, or any other SQL function
2384 that can be applied symmetrically to fields (actually B<SQL::Abstract> does
2385 not validate this option; it will just pass through what you specify verbatim).
2386
2387 =item bindtype
2388
2389 This is a kludge because many databases suck. For example, you can't
2390 just bind values using DBI's C<execute()> for Oracle C<CLOB> or C<BLOB> fields.
2391 Instead, you have to use C<bind_param()>:
2392
2393     $sth->bind_param(1, 'reg data');
2394     $sth->bind_param(2, $lots, {ora_type => ORA_CLOB});
2395
2396 The problem is, B<SQL::Abstract> will normally just return a C<@bind> array,
2397 which loses track of which field each slot refers to. Fear not.
2398
2399 If you specify C<bindtype> in new, you can determine how C<@bind> is returned.
2400 Currently, you can specify either C<normal> (default) or C<columns>. If you
2401 specify C<columns>, you will get an array that looks like this:
2402
2403     my $sql = SQL::Abstract->new(bindtype => 'columns');
2404     my($stmt, @bind) = $sql->insert(...);
2405
2406     @bind = (
2407         [ 'column1', 'value1' ],
2408         [ 'column2', 'value2' ],
2409         [ 'column3', 'value3' ],
2410     );
2411
2412 You can then iterate through this manually, using DBI's C<bind_param()>.
2413
2414     $sth->prepare($stmt);
2415     my $i = 1;
2416     for (@bind) {
2417         my($col, $data) = @$_;
2418         if ($col eq 'details' || $col eq 'comments') {
2419             $sth->bind_param($i, $data, {ora_type => ORA_CLOB});
2420         } elsif ($col eq 'image') {
2421             $sth->bind_param($i, $data, {ora_type => ORA_BLOB});
2422         } else {
2423             $sth->bind_param($i, $data);
2424         }
2425         $i++;
2426     }
2427     $sth->execute;      # execute without @bind now
2428
2429 Now, why would you still use B<SQL::Abstract> if you have to do this crap?
2430 Basically, the advantage is still that you don't have to care which fields
2431 are or are not included. You could wrap that above C<for> loop in a simple
2432 sub called C<bind_fields()> or something and reuse it repeatedly. You still
2433 get a layer of abstraction over manual SQL specification.
2434
2435 Note that if you set L</bindtype> to C<columns>, the C<\[ $sql, @bind ]>
2436 construct (see L</Literal SQL with placeholders and bind values (subqueries)>)
2437 will expect the bind values in this format.
2438
2439 =item quote_char
2440
2441 This is the character that a table or column name will be quoted
2442 with.  By default this is an empty string, but you could set it to
2443 the character C<`>, to generate SQL like this:
2444
2445   SELECT `a_field` FROM `a_table` WHERE `some_field` LIKE '%someval%'
2446
2447 Alternatively, you can supply an array ref of two items, the first being the left
2448 hand quote character, and the second the right hand quote character. For
2449 example, you could supply C<['[',']']> for SQL Server 2000 compliant quotes
2450 that generates SQL like this:
2451
2452   SELECT [a_field] FROM [a_table] WHERE [some_field] LIKE '%someval%'
2453
2454 Quoting is useful if you have tables or columns names that are reserved
2455 words in your database's SQL dialect.
2456
2457 =item escape_char
2458
2459 This is the character that will be used to escape L</quote_char>s appearing
2460 in an identifier before it has been quoted.
2461
2462 The parameter default in case of a single L</quote_char> character is the quote
2463 character itself.
2464
2465 When opening-closing-style quoting is used (L</quote_char> is an arrayref)
2466 this parameter defaults to the B<closing (right)> L</quote_char>. Occurrences
2467 of the B<opening (left)> L</quote_char> within the identifier are currently left
2468 untouched. The default for opening-closing-style quotes may change in future
2469 versions, thus you are B<strongly encouraged> to specify the escape character
2470 explicitly.
2471
2472 =item name_sep
2473
2474 This is the character that separates a table and column name.  It is
2475 necessary to specify this when the C<quote_char> option is selected,
2476 so that tables and column names can be individually quoted like this:
2477
2478   SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1
2479
2480 =item injection_guard
2481
2482 A regular expression C<qr/.../> that is applied to any C<-function> and unquoted
2483 column name specified in a query structure. This is a safety mechanism to avoid
2484 injection attacks when mishandling user input e.g.:
2485
2486   my %condition_as_column_value_pairs = get_values_from_user();
2487   $sqla->select( ... , \%condition_as_column_value_pairs );
2488
2489 If the expression matches an exception is thrown. Note that literal SQL
2490 supplied via C<\'...'> or C<\['...']> is B<not> checked in any way.
2491
2492 Defaults to checking for C<;> and the C<GO> keyword (TransactSQL)
2493
2494 =item array_datatypes
2495
2496 When this option is true, arrayrefs in INSERT or UPDATE are
2497 interpreted as array datatypes and are passed directly
2498 to the DBI layer.
2499 When this option is false, arrayrefs are interpreted
2500 as literal SQL, just like refs to arrayrefs
2501 (but this behavior is for backwards compatibility; when writing
2502 new queries, use the "reference to arrayref" syntax
2503 for literal SQL).
2504
2505
2506 =item special_ops
2507
2508 Takes a reference to a list of "special operators"
2509 to extend the syntax understood by L<SQL::Abstract>.
2510 See section L</"SPECIAL OPERATORS"> for details.
2511
2512 =item unary_ops
2513
2514 Takes a reference to a list of "unary operators"
2515 to extend the syntax understood by L<SQL::Abstract>.
2516 See section L</"UNARY OPERATORS"> for details.
2517
2518
2519
2520 =back
2521
2522 =head2 insert($table, \@values || \%fieldvals, \%options)
2523
2524 This is the simplest function. You simply give it a table name
2525 and either an arrayref of values or hashref of field/value pairs.
2526 It returns an SQL INSERT statement and a list of bind values.
2527 See the sections on L</"Inserting and Updating Arrays"> and
2528 L</"Inserting and Updating SQL"> for information on how to insert
2529 with those data types.
2530
2531 The optional C<\%options> hash reference may contain additional
2532 options to generate the insert SQL. Currently supported options
2533 are:
2534
2535 =over 4
2536
2537 =item returning
2538
2539 Takes either a scalar of raw SQL fields, or an array reference of
2540 field names, and adds on an SQL C<RETURNING> statement at the end.
2541 This allows you to return data generated by the insert statement
2542 (such as row IDs) without performing another C<SELECT> statement.
2543 Note, however, this is not part of the SQL standard and may not
2544 be supported by all database engines.
2545
2546 =back
2547
2548 =head2 update($table, \%fieldvals, \%where, \%options)
2549
2550 This takes a table, hashref of field/value pairs, and an optional
2551 hashref L<WHERE clause|/WHERE CLAUSES>. It returns an SQL UPDATE function and a list
2552 of bind values.
2553 See the sections on L</"Inserting and Updating Arrays"> and
2554 L</"Inserting and Updating SQL"> for information on how to insert
2555 with those data types.
2556
2557 The optional C<\%options> hash reference may contain additional
2558 options to generate the update SQL. Currently supported options
2559 are:
2560
2561 =over 4
2562
2563 =item returning
2564
2565 See the C<returning> option to
2566 L<insert|/insert($table, \@values || \%fieldvals, \%options)>.
2567
2568 =back
2569
2570 =head2 select($source, $fields, $where, $order)
2571
2572 This returns a SQL SELECT statement and associated list of bind values, as
2573 specified by the arguments:
2574
2575 =over
2576
2577 =item $source
2578
2579 Specification of the 'FROM' part of the statement.
2580 The argument can be either a plain scalar (interpreted as a table
2581 name, will be quoted), or an arrayref (interpreted as a list
2582 of table names, joined by commas, quoted), or a scalarref
2583 (literal SQL, not quoted).
2584
2585 =item $fields
2586
2587 Specification of the list of fields to retrieve from
2588 the source.
2589 The argument can be either an arrayref (interpreted as a list
2590 of field names, will be joined by commas and quoted), or a
2591 plain scalar (literal SQL, not quoted).
2592 Please observe that this API is not as flexible as that of
2593 the first argument C<$source>, for backwards compatibility reasons.
2594
2595 =item $where
2596
2597 Optional argument to specify the WHERE part of the query.
2598 The argument is most often a hashref, but can also be
2599 an arrayref or plain scalar --
2600 see section L<WHERE clause|/"WHERE CLAUSES"> for details.
2601
2602 =item $order
2603
2604 Optional argument to specify the ORDER BY part of the query.
2605 The argument can be a scalar, a hashref or an arrayref
2606 -- see section L<ORDER BY clause|/"ORDER BY CLAUSES">
2607 for details.
2608
2609 =back
2610
2611
2612 =head2 delete($table, \%where, \%options)
2613
2614 This takes a table name and optional hashref L<WHERE clause|/WHERE CLAUSES>.
2615 It returns an SQL DELETE statement and list of bind values.
2616
2617 The optional C<\%options> hash reference may contain additional
2618 options to generate the delete SQL. Currently supported options
2619 are:
2620
2621 =over 4
2622
2623 =item returning
2624
2625 See the C<returning> option to
2626 L<insert|/insert($table, \@values || \%fieldvals, \%options)>.
2627
2628 =back
2629
2630 =head2 where(\%where, $order)
2631
2632 This is used to generate just the WHERE clause. For example,
2633 if you have an arbitrary data structure and know what the
2634 rest of your SQL is going to look like, but want an easy way
2635 to produce a WHERE clause, use this. It returns an SQL WHERE
2636 clause and list of bind values.
2637
2638
2639 =head2 values(\%data)
2640
2641 This just returns the values from the hash C<%data>, in the same
2642 order that would be returned from any of the other above queries.
2643 Using this allows you to markedly speed up your queries if you
2644 are affecting lots of rows. See below under the L</"PERFORMANCE"> section.
2645
2646 =head2 generate($any, 'number', $of, \@data, $struct, \%types)
2647
2648 Warning: This is an experimental method and subject to change.
2649
2650 This returns arbitrarily generated SQL. It's a really basic shortcut.
2651 It will return two different things, depending on return context:
2652
2653     my($stmt, @bind) = $sql->generate('create table', \$table, \@fields);
2654     my $stmt_and_val = $sql->generate('create table', \$table, \@fields);
2655
2656 These would return the following:
2657
2658     # First calling form
2659     $stmt = "CREATE TABLE test (?, ?)";
2660     @bind = (field1, field2);
2661
2662     # Second calling form
2663     $stmt_and_val = "CREATE TABLE test (field1, field2)";
2664
2665 Depending on what you're trying to do, it's up to you to choose the correct
2666 format. In this example, the second form is what you would want.
2667
2668 By the same token:
2669
2670     $sql->generate('alter session', { nls_date_format => 'MM/YY' });
2671
2672 Might give you:
2673
2674     ALTER SESSION SET nls_date_format = 'MM/YY'
2675
2676 You get the idea. Strings get their case twiddled, but everything
2677 else remains verbatim.
2678
2679 =head1 EXPORTABLE FUNCTIONS
2680
2681 =head2 is_plain_value
2682
2683 Determines if the supplied argument is a plain value as understood by this
2684 module:
2685
2686 =over
2687
2688 =item * The value is C<undef>
2689
2690 =item * The value is a non-reference
2691
2692 =item * The value is an object with stringification overloading
2693
2694 =item * The value is of the form C<< { -value => $anything } >>
2695
2696 =back
2697
2698 On failure returns C<undef>, on success returns a B<scalar> reference
2699 to the original supplied argument.
2700
2701 =over
2702
2703 =item * Note
2704
2705 The stringification overloading detection is rather advanced: it takes
2706 into consideration not only the presence of a C<""> overload, but if that
2707 fails also checks for enabled
2708 L<autogenerated versions of C<"">|overload/Magic Autogeneration>, based
2709 on either C<0+> or C<bool>.
2710
2711 Unfortunately testing in the field indicates that this
2712 detection B<< may tickle a latent bug in perl versions before 5.018 >>,
2713 but only when very large numbers of stringifying objects are involved.
2714 At the time of writing ( Sep 2014 ) there is no clear explanation of
2715 the direct cause, nor is there a manageably small test case that reliably
2716 reproduces the problem.
2717
2718 If you encounter any of the following exceptions in B<random places within
2719 your application stack> - this module may be to blame:
2720
2721   Operation "ne": no method found,
2722     left argument in overloaded package <something>,
2723     right argument in overloaded package <something>
2724
2725 or perhaps even
2726
2727   Stub found while resolving method "???" overloading """" in package <something>
2728
2729 If you fall victim to the above - please attempt to reduce the problem
2730 to something that could be sent to the L<SQL::Abstract developers
2731 |DBIx::Class/GETTING HELP/SUPPORT>
2732 (either publicly or privately). As a workaround in the meantime you can
2733 set C<$ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}> to a true
2734 value, which will most likely eliminate your problem (at the expense of
2735 not being able to properly detect exotic forms of stringification).
2736
2737 This notice and environment variable will be removed in a future version,
2738 as soon as the underlying problem is found and a reliable workaround is
2739 devised.
2740
2741 =back
2742
2743 =head2 is_literal_value
2744
2745 Determines if the supplied argument is a literal value as understood by this
2746 module:
2747
2748 =over
2749
2750 =item * C<\$sql_string>
2751
2752 =item * C<\[ $sql_string, @bind_values ]>
2753
2754 =back
2755
2756 On failure returns C<undef>, on success returns an B<array> reference
2757 containing the unpacked version of the supplied literal SQL and bind values.
2758
2759 =head2 is_undef_value
2760
2761 Tests for undef, whether expanded or not.
2762
2763 =head1 WHERE CLAUSES
2764
2765 =head2 Introduction
2766
2767 This module uses a variation on the idea from L<DBIx::Abstract>. It
2768 is B<NOT>, repeat I<not> 100% compatible. B<The main logic of this
2769 module is that things in arrays are OR'ed, and things in hashes
2770 are AND'ed.>
2771
2772 The easiest way to explain is to show lots of examples. After
2773 each C<%where> hash shown, it is assumed you used:
2774
2775     my($stmt, @bind) = $sql->where(\%where);
2776
2777 However, note that the C<%where> hash can be used directly in any
2778 of the other functions as well, as described above.
2779
2780 =head2 Key-value pairs
2781
2782 So, let's get started. To begin, a simple hash:
2783
2784     my %where  = (
2785         user   => 'nwiger',
2786         status => 'completed'
2787     );
2788
2789 Is converted to SQL C<key = val> statements:
2790
2791     $stmt = "WHERE user = ? AND status = ?";
2792     @bind = ('nwiger', 'completed');
2793
2794 One common thing I end up doing is having a list of values that
2795 a field can be in. To do this, simply specify a list inside of
2796 an arrayref:
2797
2798     my %where  = (
2799         user   => 'nwiger',
2800         status => ['assigned', 'in-progress', 'pending'];
2801     );
2802
2803 This simple code will create the following:
2804
2805     $stmt = "WHERE user = ? AND ( status = ? OR status = ? OR status = ? )";
2806     @bind = ('nwiger', 'assigned', 'in-progress', 'pending');
2807
2808 A field associated to an empty arrayref will be considered a
2809 logical false and will generate 0=1.
2810
2811 =head2 Tests for NULL values
2812
2813 If the value part is C<undef> then this is converted to SQL <IS NULL>
2814
2815     my %where  = (
2816         user   => 'nwiger',
2817         status => undef,
2818     );
2819
2820 becomes:
2821
2822     $stmt = "WHERE user = ? AND status IS NULL";
2823     @bind = ('nwiger');
2824
2825 To test if a column IS NOT NULL:
2826
2827     my %where  = (
2828         user   => 'nwiger',
2829         status => { '!=', undef },
2830     );
2831
2832 =head2 Specific comparison operators
2833
2834 If you want to specify a different type of operator for your comparison,
2835 you can use a hashref for a given column:
2836
2837     my %where  = (
2838         user   => 'nwiger',
2839         status => { '!=', 'completed' }
2840     );
2841
2842 Which would generate:
2843
2844     $stmt = "WHERE user = ? AND status != ?";
2845     @bind = ('nwiger', 'completed');
2846
2847 To test against multiple values, just enclose the values in an arrayref:
2848
2849     status => { '=', ['assigned', 'in-progress', 'pending'] };
2850
2851 Which would give you:
2852
2853     "WHERE status = ? OR status = ? OR status = ?"
2854
2855
2856 The hashref can also contain multiple pairs, in which case it is expanded
2857 into an C<AND> of its elements:
2858
2859     my %where  = (
2860         user   => 'nwiger',
2861         status => { '!=', 'completed', -not_like => 'pending%' }
2862     );
2863
2864     # Or more dynamically, like from a form
2865     $where{user} = 'nwiger';
2866     $where{status}{'!='} = 'completed';
2867     $where{status}{'-not_like'} = 'pending%';
2868
2869     # Both generate this
2870     $stmt = "WHERE user = ? AND status != ? AND status NOT LIKE ?";
2871     @bind = ('nwiger', 'completed', 'pending%');
2872
2873
2874 To get an OR instead, you can combine it with the arrayref idea:
2875
2876     my %where => (
2877          user => 'nwiger',
2878          priority => [ { '=', 2 }, { '>', 5 } ]
2879     );
2880
2881 Which would generate:
2882
2883     $stmt = "WHERE ( priority = ? OR priority > ? ) AND user = ?";
2884     @bind = ('2', '5', 'nwiger');
2885
2886 If you want to include literal SQL (with or without bind values), just use a
2887 scalar reference or reference to an arrayref as the value:
2888
2889     my %where  = (
2890         date_entered => { '>' => \["to_date(?, 'MM/DD/YYYY')", "11/26/2008"] },
2891         date_expires => { '<' => \"now()" }
2892     );
2893
2894 Which would generate:
2895
2896     $stmt = "WHERE date_entered > to_date(?, 'MM/DD/YYYY') AND date_expires < now()";
2897     @bind = ('11/26/2008');
2898
2899
2900 =head2 Logic and nesting operators
2901
2902 In the example above,
2903 there is a subtle trap if you want to say something like
2904 this (notice the C<AND>):
2905
2906     WHERE priority != ? AND priority != ?
2907
2908 Because, in Perl you I<can't> do this:
2909
2910     priority => { '!=' => 2, '!=' => 1 }
2911
2912 As the second C<!=> key will obliterate the first. The solution
2913 is to use the special C<-modifier> form inside an arrayref:
2914
2915     priority => [ -and => {'!=', 2},
2916                           {'!=', 1} ]
2917
2918
2919 Normally, these would be joined by C<OR>, but the modifier tells it
2920 to use C<AND> instead. (Hint: You can use this in conjunction with the
2921 C<logic> option to C<new()> in order to change the way your queries
2922 work by default.) B<Important:> Note that the C<-modifier> goes
2923 B<INSIDE> the arrayref, as an extra first element. This will
2924 B<NOT> do what you think it might:
2925
2926     priority => -and => [{'!=', 2}, {'!=', 1}]   # WRONG!
2927
2928 Here is a quick list of equivalencies, since there is some overlap:
2929
2930     # Same
2931     status => {'!=', 'completed', 'not like', 'pending%' }
2932     status => [ -and => {'!=', 'completed'}, {'not like', 'pending%'}]
2933
2934     # Same
2935     status => {'=', ['assigned', 'in-progress']}
2936     status => [ -or => {'=', 'assigned'}, {'=', 'in-progress'}]
2937     status => [ {'=', 'assigned'}, {'=', 'in-progress'} ]
2938
2939
2940
2941 =head2 Special operators: IN, BETWEEN, etc.
2942
2943 You can also use the hashref format to compare a list of fields using the
2944 C<IN> comparison operator, by specifying the list as an arrayref:
2945
2946     my %where  = (
2947         status   => 'completed',
2948         reportid => { -in => [567, 2335, 2] }
2949     );
2950
2951 Which would generate:
2952
2953     $stmt = "WHERE status = ? AND reportid IN (?,?,?)";
2954     @bind = ('completed', '567', '2335', '2');
2955
2956 The reverse operator C<-not_in> generates SQL C<NOT IN> and is used in
2957 the same way.
2958
2959 If the argument to C<-in> is an empty array, 'sqlfalse' is generated
2960 (by default: C<1=0>). Similarly, C<< -not_in => [] >> generates
2961 'sqltrue' (by default: C<1=1>).
2962
2963 In addition to the array you can supply a chunk of literal sql or
2964 literal sql with bind:
2965
2966     my %where = {
2967       customer => { -in => \[
2968         'SELECT cust_id FROM cust WHERE balance > ?',
2969         2000,
2970       ],
2971       status => { -in => \'SELECT status_codes FROM states' },
2972     };
2973
2974 would generate:
2975
2976     $stmt = "WHERE (
2977           customer IN ( SELECT cust_id FROM cust WHERE balance > ? )
2978       AND status IN ( SELECT status_codes FROM states )
2979     )";
2980     @bind = ('2000');
2981
2982 Finally, if the argument to C<-in> is not a reference, it will be
2983 treated as a single-element array.
2984
2985 Another pair of operators is C<-between> and C<-not_between>,
2986 used with an arrayref of two values:
2987
2988     my %where  = (
2989         user   => 'nwiger',
2990         completion_date => {
2991            -not_between => ['2002-10-01', '2003-02-06']
2992         }
2993     );
2994
2995 Would give you:
2996
2997     WHERE user = ? AND completion_date NOT BETWEEN ( ? AND ? )
2998
2999 Just like with C<-in> all plausible combinations of literal SQL
3000 are possible:
3001
3002     my %where = {
3003       start0 => { -between => [ 1, 2 ] },
3004       start1 => { -between => \["? AND ?", 1, 2] },
3005       start2 => { -between => \"lower(x) AND upper(y)" },
3006       start3 => { -between => [
3007         \"lower(x)",
3008         \["upper(?)", 'stuff' ],
3009       ] },
3010     };
3011
3012 Would give you:
3013
3014     $stmt = "WHERE (
3015           ( start0 BETWEEN ? AND ?                )
3016       AND ( start1 BETWEEN ? AND ?                )
3017       AND ( start2 BETWEEN lower(x) AND upper(y)  )
3018       AND ( start3 BETWEEN lower(x) AND upper(?)  )
3019     )";
3020     @bind = (1, 2, 1, 2, 'stuff');
3021
3022
3023 These are the two builtin "special operators"; but the
3024 list can be expanded: see section L</"SPECIAL OPERATORS"> below.
3025
3026 =head2 Unary operators: bool
3027
3028 If you wish to test against boolean columns or functions within your
3029 database you can use the C<-bool> and C<-not_bool> operators. For
3030 example to test the column C<is_user> being true and the column
3031 C<is_enabled> being false you would use:-
3032
3033     my %where  = (
3034         -bool       => 'is_user',
3035         -not_bool   => 'is_enabled',
3036     );
3037
3038 Would give you:
3039
3040     WHERE is_user AND NOT is_enabled
3041
3042 If a more complex combination is required, testing more conditions,
3043 then you should use the and/or operators:-
3044
3045     my %where  = (
3046         -and           => [
3047             -bool      => 'one',
3048             -not_bool  => { two=> { -rlike => 'bar' } },
3049             -not_bool  => { three => [ { '=', 2 }, { '>', 5 } ] },
3050         ],
3051     );
3052
3053 Would give you:
3054
3055     WHERE
3056       one
3057         AND
3058       (NOT two RLIKE ?)
3059         AND
3060       (NOT ( three = ? OR three > ? ))
3061
3062
3063 =head2 Nested conditions, -and/-or prefixes
3064
3065 So far, we've seen how multiple conditions are joined with a top-level
3066 C<AND>.  We can change this by putting the different conditions we want in
3067 hashes and then putting those hashes in an array. For example:
3068
3069     my @where = (
3070         {
3071             user   => 'nwiger',
3072             status => { -like => ['pending%', 'dispatched'] },
3073         },
3074         {
3075             user   => 'robot',
3076             status => 'unassigned',
3077         }
3078     );
3079
3080 This data structure would create the following:
3081
3082     $stmt = "WHERE ( user = ? AND ( status LIKE ? OR status LIKE ? ) )
3083                 OR ( user = ? AND status = ? ) )";
3084     @bind = ('nwiger', 'pending', 'dispatched', 'robot', 'unassigned');
3085
3086
3087 Clauses in hashrefs or arrayrefs can be prefixed with an C<-and> or C<-or>
3088 to change the logic inside:
3089
3090     my @where = (
3091          -and => [
3092             user => 'nwiger',
3093             [
3094                 -and => [ workhrs => {'>', 20}, geo => 'ASIA' ],
3095                 -or => { workhrs => {'<', 50}, geo => 'EURO' },
3096             ],
3097         ],
3098     );
3099
3100 That would yield:
3101
3102     $stmt = "WHERE ( user = ?
3103                AND ( ( workhrs > ? AND geo = ? )
3104                   OR ( workhrs < ? OR geo = ? ) ) )";
3105     @bind = ('nwiger', '20', 'ASIA', '50', 'EURO');
3106
3107 =head3 Algebraic inconsistency, for historical reasons
3108
3109 C<Important note>: when connecting several conditions, the C<-and->|C<-or>
3110 operator goes C<outside> of the nested structure; whereas when connecting
3111 several constraints on one column, the C<-and> operator goes
3112 C<inside> the arrayref. Here is an example combining both features:
3113
3114    my @where = (
3115      -and => [a => 1, b => 2],
3116      -or  => [c => 3, d => 4],
3117       e   => [-and => {-like => 'foo%'}, {-like => '%bar'} ]
3118    )
3119
3120 yielding
3121
3122   WHERE ( (    ( a = ? AND b = ? )
3123             OR ( c = ? OR d = ? )
3124             OR ( e LIKE ? AND e LIKE ? ) ) )
3125
3126 This difference in syntax is unfortunate but must be preserved for
3127 historical reasons. So be careful: the two examples below would
3128 seem algebraically equivalent, but they are not
3129
3130   { col => [ -and =>
3131     { -like => 'foo%' },
3132     { -like => '%bar' },
3133   ] }
3134   # yields: WHERE ( ( col LIKE ? AND col LIKE ? ) )
3135
3136   [ -and =>
3137     { col => { -like => 'foo%' } },
3138     { col => { -like => '%bar' } },
3139   ]
3140   # yields: WHERE ( ( col LIKE ? OR col LIKE ? ) )
3141
3142
3143 =head2 Literal SQL and value type operators
3144
3145 The basic premise of SQL::Abstract is that in WHERE specifications the "left
3146 side" is a column name and the "right side" is a value (normally rendered as
3147 a placeholder). This holds true for both hashrefs and arrayref pairs as you
3148 see in the L</WHERE CLAUSES> examples above. Sometimes it is necessary to
3149 alter this behavior. There are several ways of doing so.
3150
3151 =head3 -ident
3152
3153 This is a virtual operator that signals the string to its right side is an
3154 identifier (a column name) and not a value. For example to compare two
3155 columns you would write:
3156
3157     my %where = (
3158         priority => { '<', 2 },
3159         requestor => { -ident => 'submitter' },
3160     );
3161
3162 which creates:
3163
3164     $stmt = "WHERE priority < ? AND requestor = submitter";
3165     @bind = ('2');
3166
3167 If you are maintaining legacy code you may see a different construct as
3168 described in L</Deprecated usage of Literal SQL>, please use C<-ident> in new
3169 code.
3170
3171 =head3 -value
3172
3173 This is a virtual operator that signals that the construct to its right side
3174 is a value to be passed to DBI. This is for example necessary when you want
3175 to write a where clause against an array (for RDBMS that support such
3176 datatypes). For example:
3177
3178     my %where = (
3179         array => { -value => [1, 2, 3] }
3180     );
3181
3182 will result in:
3183
3184     $stmt = 'WHERE array = ?';
3185     @bind = ([1, 2, 3]);
3186
3187 Note that if you were to simply say:
3188
3189     my %where = (
3190         array => [1, 2, 3]
3191     );
3192
3193 the result would probably not be what you wanted:
3194
3195     $stmt = 'WHERE array = ? OR array = ? OR array = ?';
3196     @bind = (1, 2, 3);
3197
3198 =head3 Literal SQL
3199
3200 Finally, sometimes only literal SQL will do. To include a random snippet
3201 of SQL verbatim, you specify it as a scalar reference. Consider this only
3202 as a last resort. Usually there is a better way. For example:
3203
3204     my %where = (
3205         priority => { '<', 2 },
3206         requestor => { -in => \'(SELECT name FROM hitmen)' },
3207     );
3208
3209 Would create:
3210
3211     $stmt = "WHERE priority < ? AND requestor IN (SELECT name FROM hitmen)"
3212     @bind = (2);
3213
3214 Note that in this example, you only get one bind parameter back, since
3215 the verbatim SQL is passed as part of the statement.
3216
3217 =head4 CAVEAT
3218
3219   Never use untrusted input as a literal SQL argument - this is a massive
3220   security risk (there is no way to check literal snippets for SQL
3221   injections and other nastyness). If you need to deal with untrusted input
3222   use literal SQL with placeholders as described next.
3223
3224 =head3 Literal SQL with placeholders and bind values (subqueries)
3225
3226 If the literal SQL to be inserted has placeholders and bind values,
3227 use a reference to an arrayref (yes this is a double reference --
3228 not so common, but perfectly legal Perl). For example, to find a date
3229 in Postgres you can use something like this:
3230
3231     my %where = (
3232        date_column => \[ "= date '2008-09-30' - ?::integer", 10 ]
3233     )
3234
3235 This would create:
3236
3237     $stmt = "WHERE ( date_column = date '2008-09-30' - ?::integer )"
3238     @bind = ('10');
3239
3240 Note that you must pass the bind values in the same format as they are returned
3241 by L<where|/where(\%where, $order)>. This means that if you set L</bindtype>
3242 to C<columns>, you must provide the bind values in the
3243 C<< [ column_meta => value ] >> format, where C<column_meta> is an opaque
3244 scalar value; most commonly the column name, but you can use any scalar value
3245 (including references and blessed references), L<SQL::Abstract> will simply
3246 pass it through intact. So if C<bindtype> is set to C<columns> the above
3247 example will look like:
3248
3249     my %where = (
3250        date_column => \[ "= date '2008-09-30' - ?::integer", [ {} => 10 ] ]
3251     )
3252
3253 Literal SQL is especially useful for nesting parenthesized clauses in the
3254 main SQL query. Here is a first example:
3255
3256   my ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
3257                                100, "foo%");
3258   my %where = (
3259     foo => 1234,
3260     bar => \["IN ($sub_stmt)" => @sub_bind],
3261   );
3262
3263 This yields:
3264
3265   $stmt = "WHERE (foo = ? AND bar IN (SELECT c1 FROM t1
3266                                              WHERE c2 < ? AND c3 LIKE ?))";
3267   @bind = (1234, 100, "foo%");
3268
3269 Other subquery operators, like for example C<"E<gt> ALL"> or C<"NOT IN">,
3270 are expressed in the same way. Of course the C<$sub_stmt> and
3271 its associated bind values can be generated through a former call
3272 to C<select()> :
3273
3274   my ($sub_stmt, @sub_bind)
3275      = $sql->select("t1", "c1", {c2 => {"<" => 100},
3276                                  c3 => {-like => "foo%"}});
3277   my %where = (
3278     foo => 1234,
3279     bar => \["> ALL ($sub_stmt)" => @sub_bind],
3280   );
3281
3282 In the examples above, the subquery was used as an operator on a column;
3283 but the same principle also applies for a clause within the main C<%where>
3284 hash, like an EXISTS subquery:
3285
3286   my ($sub_stmt, @sub_bind)
3287      = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"});
3288   my %where = ( -and => [
3289     foo   => 1234,
3290     \["EXISTS ($sub_stmt)" => @sub_bind],
3291   ]);
3292
3293 which yields
3294
3295   $stmt = "WHERE (foo = ? AND EXISTS (SELECT * FROM t1
3296                                         WHERE c1 = ? AND c2 > t0.c0))";
3297   @bind = (1234, 1);
3298
3299
3300 Observe that the condition on C<c2> in the subquery refers to
3301 column C<t0.c0> of the main query: this is I<not> a bind
3302 value, so we have to express it through a scalar ref.
3303 Writing C<< c2 => {">" => "t0.c0"} >> would have generated
3304 C<< c2 > ? >> with bind value C<"t0.c0"> ... not exactly
3305 what we wanted here.
3306
3307 Finally, here is an example where a subquery is used
3308 for expressing unary negation:
3309
3310   my ($sub_stmt, @sub_bind)
3311      = $sql->where({age => [{"<" => 10}, {">" => 20}]});
3312   $sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause
3313   my %where = (
3314         lname  => {like => '%son%'},
3315         \["NOT ($sub_stmt)" => @sub_bind],
3316     );
3317
3318 This yields
3319
3320   $stmt = "lname LIKE ? AND NOT ( age < ? OR age > ? )"
3321   @bind = ('%son%', 10, 20)
3322
3323 =head3 Deprecated usage of Literal SQL
3324
3325 Below are some examples of archaic use of literal SQL. It is shown only as
3326 reference for those who deal with legacy code. Each example has a much
3327 better, cleaner and safer alternative that users should opt for in new code.
3328
3329 =over
3330
3331 =item *
3332
3333     my %where = ( requestor => \'IS NOT NULL' )
3334
3335     $stmt = "WHERE requestor IS NOT NULL"
3336
3337 This used to be the way of generating NULL comparisons, before the handling
3338 of C<undef> got formalized. For new code please use the superior syntax as
3339 described in L</Tests for NULL values>.
3340
3341 =item *
3342
3343     my %where = ( requestor => \'= submitter' )
3344
3345     $stmt = "WHERE requestor = submitter"
3346
3347 This used to be the only way to compare columns. Use the superior L</-ident>
3348 method for all new code. For example an identifier declared in such a way
3349 will be properly quoted if L</quote_char> is properly set, while the legacy
3350 form will remain as supplied.
3351
3352 =item *
3353
3354     my %where = ( is_ready  => \"", completed => { '>', '2012-12-21' } )
3355
3356     $stmt = "WHERE completed > ? AND is_ready"
3357     @bind = ('2012-12-21')
3358
3359 Using an empty string literal used to be the only way to express a boolean.
3360 For all new code please use the much more readable
3361 L<-bool|/Unary operators: bool> operator.
3362
3363 =back
3364
3365 =head2 Conclusion
3366
3367 These pages could go on for a while, since the nesting of the data
3368 structures this module can handle are pretty much unlimited (the
3369 module implements the C<WHERE> expansion as a recursive function
3370 internally). Your best bet is to "play around" with the module a
3371 little to see how the data structures behave, and choose the best
3372 format for your data based on that.
3373
3374 And of course, all the values above will probably be replaced with
3375 variables gotten from forms or the command line. After all, if you
3376 knew everything ahead of time, you wouldn't have to worry about
3377 dynamically-generating SQL and could just hardwire it into your
3378 script.
3379
3380 =head1 ORDER BY CLAUSES
3381
3382 Some functions take an order by clause. This can either be a scalar (just a
3383 column name), a hashref of C<< { -desc => 'col' } >> or C<< { -asc => 'col' }
3384 >>, a scalarref, an arrayref-ref, or an arrayref of any of the previous
3385 forms. Examples:
3386
3387                Given              |         Will Generate
3388     ---------------------------------------------------------------
3389                                   |
3390     'colA'                        | ORDER BY colA
3391                                   |
3392     [qw/colA colB/]               | ORDER BY colA, colB
3393                                   |
3394     {-asc  => 'colA'}             | ORDER BY colA ASC
3395                                   |
3396     {-desc => 'colB'}             | ORDER BY colB DESC
3397                                   |
3398     ['colA', {-asc => 'colB'}]    | ORDER BY colA, colB ASC
3399                                   |
3400     { -asc => [qw/colA colB/] }   | ORDER BY colA ASC, colB ASC
3401                                   |
3402     \'colA DESC'                  | ORDER BY colA DESC
3403                                   |
3404     \[ 'FUNC(colA, ?)', $x ]      | ORDER BY FUNC(colA, ?)
3405                                   |   /* ...with $x bound to ? */
3406                                   |
3407     [                             | ORDER BY
3408       { -asc => 'colA' },         |     colA ASC,
3409       { -desc => [qw/colB/] },    |     colB DESC,
3410       { -asc => [qw/colC colD/] },|     colC ASC, colD ASC,
3411       \'colE DESC',               |     colE DESC,
3412       \[ 'FUNC(colF, ?)', $x ],   |     FUNC(colF, ?)
3413     ]                             |   /* ...with $x bound to ? */
3414     ===============================================================
3415
3416
3417
3418 =head1 OLD EXTENSION SYSTEM
3419
3420 =head2 SPECIAL OPERATORS
3421
3422   my $sqlmaker = SQL::Abstract->new(special_ops => [
3423      {
3424       regex => qr/.../,
3425       handler => sub {
3426         my ($self, $field, $op, $arg) = @_;
3427         ...
3428       },
3429      },
3430      {
3431       regex => qr/.../,
3432       handler => 'method_name',
3433      },
3434    ]);
3435
3436 A "special operator" is a SQL syntactic clause that can be
3437 applied to a field, instead of a usual binary operator.
3438 For example:
3439
3440    WHERE field IN (?, ?, ?)
3441    WHERE field BETWEEN ? AND ?
3442    WHERE MATCH(field) AGAINST (?, ?)
3443
3444 Special operators IN and BETWEEN are fairly standard and therefore
3445 are builtin within C<SQL::Abstract> (as the overridable methods
3446 C<_where_field_IN> and C<_where_field_BETWEEN>). For other operators,
3447 like the MATCH .. AGAINST example above which is specific to MySQL,
3448 you can write your own operator handlers - supply a C<special_ops>
3449 argument to the C<new> method. That argument takes an arrayref of
3450 operator definitions; each operator definition is a hashref with two
3451 entries:
3452
3453 =over
3454
3455 =item regex
3456
3457 the regular expression to match the operator
3458
3459 =item handler
3460
3461 Either a coderef or a plain scalar method name. In both cases
3462 the expected return is C<< ($sql, @bind) >>.
3463
3464 When supplied with a method name, it is simply called on the
3465 L<SQL::Abstract> object as:
3466
3467  $self->$method_name($field, $op, $arg)
3468
3469  Where:
3470
3471   $field is the LHS of the operator
3472   $op is the part that matched the handler regex
3473   $arg is the RHS
3474
3475 When supplied with a coderef, it is called as:
3476
3477  $coderef->($self, $field, $op, $arg)
3478
3479
3480 =back
3481
3482 For example, here is an implementation
3483 of the MATCH .. AGAINST syntax for MySQL
3484
3485   my $sqlmaker = SQL::Abstract->new(special_ops => [
3486
3487     # special op for MySql MATCH (field) AGAINST(word1, word2, ...)
3488     {regex => qr/^match$/i,
3489      handler => sub {
3490        my ($self, $field, $op, $arg) = @_;
3491        $arg = [$arg] if not ref $arg;
3492        my $label         = $self->_quote($field);
3493        my ($placeholder) = $self->_convert('?');
3494        my $placeholders  = join ", ", (($placeholder) x @$arg);
3495        my $sql           = $self->_sqlcase('match') . " ($label) "
3496                          . $self->_sqlcase('against') . " ($placeholders) ";
3497        my @bind = $self->_bindtype($field, @$arg);
3498        return ($sql, @bind);
3499        }
3500      },
3501
3502   ]);
3503
3504
3505 =head2 UNARY OPERATORS
3506
3507   my $sqlmaker = SQL::Abstract->new(unary_ops => [
3508      {
3509       regex => qr/.../,
3510       handler => sub {
3511         my ($self, $op, $arg) = @_;
3512         ...
3513       },
3514      },
3515      {
3516       regex => qr/.../,
3517       handler => 'method_name',
3518      },
3519    ]);
3520
3521 A "unary operator" is a SQL syntactic clause that can be
3522 applied to a field - the operator goes before the field
3523
3524 You can write your own operator handlers - supply a C<unary_ops>
3525 argument to the C<new> method. That argument takes an arrayref of
3526 operator definitions; each operator definition is a hashref with two
3527 entries:
3528
3529 =over
3530
3531 =item regex
3532
3533 the regular expression to match the operator
3534
3535 =item handler
3536
3537 Either a coderef or a plain scalar method name. In both cases
3538 the expected return is C<< $sql >>.
3539
3540 When supplied with a method name, it is simply called on the
3541 L<SQL::Abstract> object as:
3542
3543  $self->$method_name($op, $arg)
3544
3545  Where:
3546
3547   $op is the part that matched the handler regex
3548   $arg is the RHS or argument of the operator
3549
3550 When supplied with a coderef, it is called as:
3551
3552  $coderef->($self, $op, $arg)
3553
3554
3555 =back
3556
3557 =head1 NEW METHODS (EXPERIMENTAL)
3558
3559 See L<SQL::Abstract::Reference> for the C<expr> versus C<aqt> concept and
3560 an explanation of what the below extensions are extending.
3561
3562 =head2 plugin
3563
3564   $sqla->plugin('+Foo');
3565
3566 Enables plugin SQL::Abstract::Plugin::Foo.
3567
3568 =head2 render_expr
3569
3570   my ($sql, @bind) = $sqla->render_expr($expr);
3571
3572 =head2 render_statement
3573
3574 Use this if you may be rendering a top level statement so e.g. a SELECT
3575 query doesn't get wrapped in parens
3576
3577   my ($sql, @bind) = $sqla->render_statement($expr);
3578
3579 =head2 expand_expr
3580
3581 Expression expansion with optional default for scalars.
3582
3583   my $aqt = $self->expand_expr($expr);
3584   my $aqt = $self->expand_expr($expr, -ident);
3585
3586 =head2 render_aqt
3587
3588 Top level means avoid parens on statement AQT.
3589
3590   my $res = $self->render_aqt($aqt, $top_level);
3591   my ($sql, @bind) = @$res;
3592
3593 =head2 join_query_parts
3594
3595 Similar to join() but will render hashrefs as nodes for both join and parts,
3596 and treats arrayref as a nested C<[ $join, @parts ]> structure.
3597
3598   my $part = $self->join_query_parts($join, @parts);
3599
3600 =head1 NEW EXTENSION SYSTEM
3601
3602 =head2 clone
3603
3604   my $sqla2 = $sqla->clone;
3605
3606 Performs a semi-shallow copy such that extension methods won't leak state
3607 but excessive depth is avoided.
3608
3609 =head2 expander
3610
3611 =head2 expanders
3612
3613 =head2 op_expander
3614
3615 =head2 op_expanders
3616
3617 =head2 clause_expander
3618
3619 =head2 clause_expanders
3620
3621   $sqla->expander('name' => sub { ... });
3622   $sqla->expanders('name1' => sub { ... }, 'name2' => sub { ... });
3623
3624 =head2 expander_list
3625
3626 =head2 op_expander_list
3627
3628 =head2 clause_expander_list
3629
3630   my @names = $sqla->expander_list;
3631
3632 =head2 wrap_expander
3633
3634 =head2 wrap_expanders
3635
3636 =head2 wrap_op_expander
3637
3638 =head2 wrap_op_expanders
3639
3640 =head2 wrap_clause_expander
3641
3642 =head2 wrap_clause_expanders
3643
3644   $sqla->wrap_expander('name' => sub { my ($orig) = @_; sub { ... } });
3645   $sqla->wrap_expanders(
3646     'name1' => sub { my ($orig1) = @_; sub { ... } },
3647     'name2' => sub { my ($orig2) = @_; sub { ... } },
3648   );
3649
3650 =head2 renderer
3651
3652 =head2 renderers
3653
3654 =head2 op_renderer
3655
3656 =head2 op_renderers
3657
3658 =head2 clause_renderer
3659
3660 =head2 clause_renderers
3661
3662   $sqla->renderer('name' => sub { ... });
3663   $sqla->renderers('name1' => sub { ... }, 'name2' => sub { ... });
3664
3665 =head2 renderer_list
3666
3667 =head2 op_renderer_list
3668
3669 =head2 clause_renderer_list
3670
3671   my @names = $sqla->renderer_list;
3672
3673 =head2 wrap_renderer
3674
3675 =head2 wrap_renderers
3676
3677 =head2 wrap_op_renderer
3678
3679 =head2 wrap_op_renderers
3680
3681 =head2 wrap_clause_renderer
3682
3683 =head2 wrap_clause_renderers
3684
3685   $sqla->wrap_renderer('name' => sub { my ($orig) = @_; sub { ... } });
3686   $sqla->wrap_renderers(
3687     'name1' => sub { my ($orig1) = @_; sub { ... } },
3688     'name2' => sub { my ($orig2) = @_; sub { ... } },
3689   );
3690
3691 =head2 clauses_of
3692
3693   my @clauses = $sqla->clauses_of('select');
3694   $sqla->clauses_of(select => \@new_clauses);
3695   $sqla->clauses_of(select => sub {
3696     my (undef, @old_clauses) = @_;
3697     ...
3698     return @new_clauses;
3699   });
3700
3701 =head2 statement_list
3702
3703   my @list = $sqla->statement_list;
3704
3705 =head2 make_unop_expander
3706
3707   my $exp = $sqla->make_unop_expander(sub { ... });
3708
3709 If the op is found as a binop, assumes it wants a default comparison, so
3710 the inner expander sub can reliably operate as
3711
3712   sub { my ($self, $name, $body) = @_; ... }
3713
3714 =head2 make_binop_expander
3715
3716   my $exp = $sqla->make_binop_expander(sub { ... });
3717
3718 If the op is found as a unop, assumes the value will be an arrayref with the
3719 LHS as the first entry, and converts that to an ident node if it's a simple
3720 scalar. So the inner expander sub looks like
3721
3722   sub {
3723     my ($self, $name, $body, $k) = @_;
3724     { -blah => [ map $self->expand_expr($_), $k, $body ] }
3725   }
3726
3727 =head2 unop_expander
3728
3729 =head2 unop_expanders
3730
3731 =head2 binop_expander
3732
3733 =head2 binop_expanders
3734
3735 The above methods operate exactly like the op_ versions but wrap the coderef
3736 using the appropriate make_ method first.
3737
3738 =head1 PERFORMANCE
3739
3740 Thanks to some benchmarking by Mark Stosberg, it turns out that
3741 this module is many orders of magnitude faster than using C<DBIx::Abstract>.
3742 I must admit this wasn't an intentional design issue, but it's a
3743 byproduct of the fact that you get to control your C<DBI> handles
3744 yourself.
3745
3746 To maximize performance, use a code snippet like the following:
3747
3748     # prepare a statement handle using the first row
3749     # and then reuse it for the rest of the rows
3750     my($sth, $stmt);
3751     for my $href (@array_of_hashrefs) {
3752         $stmt ||= $sql->insert('table', $href);
3753         $sth  ||= $dbh->prepare($stmt);
3754         $sth->execute($sql->values($href));
3755     }
3756
3757 The reason this works is because the keys in your C<$href> are sorted
3758 internally by B<SQL::Abstract>. Thus, as long as your data retains
3759 the same structure, you only have to generate the SQL the first time
3760 around. On subsequent queries, simply use the C<values> function provided
3761 by this module to return your values in the correct order.
3762
3763 However this depends on the values having the same type - if, for
3764 example, the values of a where clause may either have values
3765 (resulting in sql of the form C<column = ?> with a single bind
3766 value), or alternatively the values might be C<undef> (resulting in
3767 sql of the form C<column IS NULL> with no bind value) then the
3768 caching technique suggested will not work.
3769
3770 =head1 FORMBUILDER
3771
3772 If you use my C<CGI::FormBuilder> module at all, you'll hopefully
3773 really like this part (I do, at least). Building up a complex query
3774 can be as simple as the following:
3775
3776     #!/usr/bin/perl
3777
3778     use warnings;
3779     use strict;
3780
3781     use CGI::FormBuilder;
3782     use SQL::Abstract;
3783
3784     my $form = CGI::FormBuilder->new(...);
3785     my $sql  = SQL::Abstract->new;
3786
3787     if ($form->submitted) {
3788         my $field = $form->field;
3789         my $id = delete $field->{id};
3790         my($stmt, @bind) = $sql->update('table', $field, {id => $id});
3791     }
3792
3793 Of course, you would still have to connect using C<DBI> to run the
3794 query, but the point is that if you make your form look like your
3795 table, the actual query script can be extremely simplistic.
3796
3797 If you're B<REALLY> lazy (I am), check out C<HTML::QuickTable> for
3798 a fast interface to returning and formatting data. I frequently
3799 use these three modules together to write complex database query
3800 apps in under 50 lines.
3801
3802 =head1 HOW TO CONTRIBUTE
3803
3804 Contributions are always welcome, in all usable forms (we especially
3805 welcome documentation improvements). The delivery methods include git-
3806 or unified-diff formatted patches, GitHub pull requests, or plain bug
3807 reports either via RT or the Mailing list. Contributors are generally
3808 granted full access to the official repository after their first several
3809 patches pass successful review.
3810
3811 This project is maintained in a git repository. The code and related tools are
3812 accessible at the following locations:
3813
3814 =over
3815
3816 =item * Official repo: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Abstract.git>
3817
3818 =item * Official gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/SQL-Abstract.git>
3819
3820 =item * GitHub mirror: L<https://github.com/dbsrgits/sql-abstract>
3821
3822 =item * Authorized committers: L<ssh://dbsrgits@git.shadowcat.co.uk/SQL-Abstract.git>
3823
3824 =back
3825
3826 =head1 CHANGES
3827
3828 Version 1.50 was a major internal refactoring of C<SQL::Abstract>.
3829 Great care has been taken to preserve the I<published> behavior
3830 documented in previous versions in the 1.* family; however,
3831 some features that were previously undocumented, or behaved
3832 differently from the documentation, had to be changed in order
3833 to clarify the semantics. Hence, client code that was relying
3834 on some dark areas of C<SQL::Abstract> v1.*
3835 B<might behave differently> in v1.50.
3836
3837 The main changes are:
3838
3839 =over
3840
3841 =item *
3842
3843 support for literal SQL through the C<< \ [ $sql, @bind ] >> syntax.
3844
3845 =item *
3846
3847 support for the { operator => \"..." } construct (to embed literal SQL)
3848
3849 =item *
3850
3851 support for the { operator => \["...", @bind] } construct (to embed literal SQL with bind values)
3852
3853 =item *
3854
3855 optional support for L<array datatypes|/"Inserting and Updating Arrays">
3856
3857 =item *
3858
3859 defensive programming: check arguments
3860
3861 =item *
3862
3863 fixed bug with global logic, which was previously implemented
3864 through global variables yielding side-effects. Prior versions would
3865 interpret C<< [ {cond1, cond2}, [cond3, cond4] ] >>
3866 as C<< "(cond1 AND cond2) OR (cond3 AND cond4)" >>.
3867 Now this is interpreted
3868 as C<< "(cond1 AND cond2) OR (cond3 OR cond4)" >>.
3869
3870
3871 =item *
3872
3873 fixed semantics of  _bindtype on array args
3874
3875 =item *
3876
3877 dropped the C<_anoncopy> of the %where tree. No longer necessary,
3878 we just avoid shifting arrays within that tree.
3879
3880 =item *
3881
3882 dropped the C<_modlogic> function
3883
3884 =back
3885
3886 =head1 ACKNOWLEDGEMENTS
3887
3888 There are a number of individuals that have really helped out with
3889 this module. Unfortunately, most of them submitted bugs via CPAN
3890 so I have no idea who they are! But the people I do know are:
3891
3892     Ash Berlin (order_by hash term support)
3893     Matt Trout (DBIx::Class support)
3894     Mark Stosberg (benchmarking)
3895     Chas Owens (initial "IN" operator support)
3896     Philip Collins (per-field SQL functions)
3897     Eric Kolve (hashref "AND" support)
3898     Mike Fragassi (enhancements to "BETWEEN" and "LIKE")
3899     Dan Kubb (support for "quote_char" and "name_sep")
3900     Guillermo Roditi (patch to cleanup "IN" and "BETWEEN", fix and tests for _order_by)
3901     Laurent Dami (internal refactoring, extensible list of special operators, literal SQL)
3902     Norbert Buchmuller (support for literal SQL in hashpair, misc. fixes & tests)
3903     Peter Rabbitson (rewrite of SQLA::Test, misc. fixes & tests)
3904     Oliver Charles (support for "RETURNING" after "INSERT")
3905
3906 Thanks!
3907
3908 =head1 SEE ALSO
3909
3910 L<DBIx::Class>, L<DBIx::Abstract>, L<CGI::FormBuilder>, L<HTML::QuickTable>.
3911
3912 =head1 AUTHOR
3913
3914 Copyright (c) 2001-2007 Nathan Wiger <nwiger@cpan.org>. All Rights Reserved.
3915
3916 This module is actively maintained by Matt Trout <mst@shadowcatsystems.co.uk>
3917
3918 For support, your best bet is to try the C<DBIx::Class> users mailing list.
3919 While not an official support venue, C<DBIx::Class> makes heavy use of
3920 C<SQL::Abstract>, and as such list members there are very familiar with
3921 how to create queries.
3922
3923 =head1 LICENSE
3924
3925 This module is free software; you may copy this under the same
3926 terms as perl itself (either the GNU General Public License or
3927 the Artistic License)
3928
3929 =cut