lib/SQL/Abstract.pm

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