lib/SQL/Abstract.pm

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