lib/SQL/Abstract.pm

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