use List::Util ();
use Scalar::Util ();
+use Exporter 'import';
+our @EXPORT_OK = qw(is_plain_value is_literal_value);
+
+BEGIN {
+ if ($] < 5.009_005) {
+ require MRO::Compat;
+ }
+ else {
+ require mro;
+ }
+
+ *SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION = $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}
+ ? sub () { 0 }
+ : sub () { 1 }
+ ;
+}
+
#======================================================================
# GLOBALS
#======================================================================
-our $VERSION = '1.74';
+our $VERSION = '1.86';
# This would confuse some packagers
$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
# special operators (-in, -between). May be extended/overridden by user.
# See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation
my @BUILTIN_SPECIAL_OPS = (
- {regex => qr/^ (?: not \s )? between $/ix, handler => '_where_field_BETWEEN'},
- {regex => qr/^ (?: not \s )? in $/ix, handler => '_where_field_IN'},
- {regex => qr/^ ident $/ix, handler => '_where_op_IDENT'},
- {regex => qr/^ value $/ix, handler => '_where_op_VALUE'},
+ {regex => qr/^ (?: not \s )? between $/ix, handler => sub { die "NOPE" }},
+ {regex => qr/^ (?: not \s )? in $/ix, handler => sub { die "NOPE" }},
+ {regex => qr/^ ident $/ix, handler => sub { die "NOPE" }},
+ {regex => qr/^ value $/ix, handler => sub { die "NOPE" }},
+ {regex => qr/^ is (?: \s+ not )? $/ix, handler => sub { die "NOPE" }},
);
# unaryish operators - key maps to handler
{ regex => qr/^ nest (?: [_\s]? \d+ )? $/xi, handler => '_where_op_NEST' },
{ regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' },
{ regex => qr/^ ident $/xi, handler => '_where_op_IDENT' },
- { regex => qr/^ value $/ix, handler => '_where_op_VALUE' },
+ { regex => qr/^ value $/xi, handler => '_where_op_VALUE' },
+ { regex => qr/^ op $/xi, handler => '_where_op_OP' },
+ { regex => qr/^ bind $/xi, handler => '_where_op_BIND' },
+ { regex => qr/^ literal $/xi, handler => '_where_op_LITERAL' },
+ { regex => qr/^ func $/xi, handler => '_where_op_FUNC' },
);
#======================================================================
Carp::croak "[$func] Fatal: ", @_;
}
+sub is_literal_value ($) {
+ ref $_[0] eq 'SCALAR' ? [ ${$_[0]} ]
+ : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) ? [ @${ $_[0] } ]
+ : undef;
+}
+
+# FIXME XSify - this can be done so much more efficiently
+sub is_plain_value ($) {
+ no strict 'refs';
+ ! length ref $_[0] ? \($_[0])
+ : (
+ ref $_[0] eq 'HASH' and keys %{$_[0]} == 1
+ and
+ exists $_[0]->{-value}
+ ) ? \($_[0]->{-value})
+ : (
+ # reuse @_ for even moar speedz
+ defined ( $_[1] = Scalar::Util::blessed $_[0] )
+ and
+ # deliberately not using Devel::OverloadInfo - the checks we are
+ # intersted in are much more limited than the fullblown thing, and
+ # this is a very hot piece of code
+ (
+ # simply using ->can('(""') can leave behind stub methods that
+ # break actually using the overload later (see L<perldiag/Stub
+ # found while resolving method "%s" overloading "%s" in package
+ # "%s"> and the source of overload::mycan())
+ #
+ # either has stringification which DBI SHOULD prefer out of the box
+ grep { *{ (qq[${_}::(""]) }{CODE} } @{ $_[2] = mro::get_linear_isa( $_[1] ) }
+ or
+ # has nummification or boolification, AND fallback is *not* disabled
+ (
+ SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION
+ and
+ (
+ grep { *{"${_}::(0+"}{CODE} } @{$_[2]}
+ or
+ grep { *{"${_}::(bool"}{CODE} } @{$_[2]}
+ )
+ and
+ (
+ # no fallback specified at all
+ ! ( ($_[3]) = grep { *{"${_}::()"}{CODE} } @{$_[2]} )
+ or
+ # fallback explicitly undef
+ ! defined ${"$_[3]::()"}
+ or
+ # explicitly true
+ !! ${"$_[3]::()"}
+ )
+ )
+ )
+ ) ? \($_[0])
+ : undef;
+}
+
+
#======================================================================
# NEW
$opt{sqlfalse} ||= '0=1';
# special operators
- $opt{special_ops} ||= [];
+ $opt{user_special_ops} = [ @{$opt{special_ops} ||= []} ];
# regexes are applied in order, thus push after user-defines
push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
$sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
if ($options->{returning}) {
- my ($s, @b) = $self->_insert_returning ($options);
+ my ($s, @b) = $self->_insert_returning($options);
$sql .= $s;
push @bind, @b;
}
return wantarray ? ($sql, @bind) : $sql;
}
-sub _insert_returning {
+# So that subclasses can override INSERT ... RETURNING separately from
+# UPDATE and DELETE (e.g. DBIx::Class::SQLMaker::Oracle does this)
+sub _insert_returning { shift->_returning(@_) }
+
+sub _returning {
my ($self, $options) = @_;
my $f = $options->{returning};
$self->{bindtype} ne 'columns'
or belch "can't do 'columns' bindtype when called with arrayref";
- # fold the list of values into a hash of column name - value pairs
- # (where the column names are artificially generated, and their
- # lexicographical ordering keep the ordering of the original list)
- my $i = "a"; # incremented values will be in lexicographical order
- my $data_in_hash = { map { ($i++ => $_) } @$data };
-
- return $self->_insert_values($data_in_hash);
+ my (@values, @all_bind);
+ foreach my $value (@$data) {
+ my ($values, @bind) = $self->_insert_value(undef, $value);
+ push @values, $values;
+ push @all_bind, @bind;
+ }
+ my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
+ return ($sql, @all_bind);
}
sub _insert_ARRAYREFREF { # literal SQL with bind
my (@values, @all_bind);
foreach my $column (sort keys %$data) {
- my $v = $data->{$column};
+ my ($values, @bind) = $self->_insert_value($column, $data->{$column});
+ push @values, $values;
+ push @all_bind, @bind;
+ }
+ my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
+ return ($sql, @all_bind);
+}
- $self->_SWITCH_refkind($v, {
+sub _insert_value {
+ my ($self, $column, $v) = @_;
- ARRAYREF => sub {
- if ($self->{array_datatypes}) { # if array datatype are activated
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- }
- else { # else literal SQL with bind
- my ($sql, @bind) = @$v;
- $self->_assert_bindval_matches_bindtype(@bind);
- push @values, $sql;
- push @all_bind, @bind;
- }
- },
+ my (@values, @all_bind);
+ $self->_SWITCH_refkind($v, {
- ARRAYREFREF => sub { # literal SQL with bind
- my ($sql, @bind) = @${$v};
+ ARRAYREF => sub {
+ if ($self->{array_datatypes}) { # if array datatype are activated
+ push @values, '?';
+ push @all_bind, $self->_bindtype($column, $v);
+ }
+ else { # else literal SQL with bind
+ my ($sql, @bind) = @$v;
$self->_assert_bindval_matches_bindtype(@bind);
push @values, $sql;
push @all_bind, @bind;
- },
+ }
+ },
- # THINK : anything useful to do with a HASHREF ?
- HASHREF => sub { # (nothing, but old SQLA passed it through)
- #TODO in SQLA >= 2.0 it will die instead
- belch "HASH ref as bind value in insert is not supported";
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- },
+ ARRAYREFREF => sub { # literal SQL with bind
+ my ($sql, @bind) = @${$v};
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @values, $sql;
+ push @all_bind, @bind;
+ },
- SCALARREF => sub { # literal SQL without bind
- push @values, $$v;
- },
+ # THINK: anything useful to do with a HASHREF ?
+ HASHREF => sub { # (nothing, but old SQLA passed it through)
+ #TODO in SQLA >= 2.0 it will die instead
+ belch "HASH ref as bind value in insert is not supported";
+ push @values, '?';
+ push @all_bind, $self->_bindtype($column, $v);
+ },
- SCALAR_or_UNDEF => sub {
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- },
+ SCALARREF => sub { # literal SQL without bind
+ push @values, $$v;
+ },
- });
+ SCALAR_or_UNDEF => sub {
+ push @values, '?';
+ push @all_bind, $self->_bindtype($column, $v);
+ },
- }
+ });
- my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
+ my $sql = join(", ", @values);
return ($sql, @all_bind);
}
sub update {
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
- my $where = shift;
+ my $self = shift;
+ my $table = $self->_table(shift);
+ my $data = shift || return;
+ my $where = shift;
+ my $options = shift;
# first build the 'SET' part of the sql statement
- my (@set, @all_bind);
puke "Unsupported data type specified to \$sql->update"
unless ref $data eq 'HASH';
+ my ($sql, @all_bind) = $self->_update_set_values($data);
+ $sql = $self->_sqlcase('update ') . $table . $self->_sqlcase(' set ')
+ . $sql;
+
+ if ($where) {
+ my($where_sql, @where_bind) = $self->where($where);
+ $sql .= $where_sql;
+ push @all_bind, @where_bind;
+ }
+
+ if ($options->{returning}) {
+ my ($returning_sql, @returning_bind) = $self->_update_returning($options);
+ $sql .= $returning_sql;
+ push @all_bind, @returning_bind;
+ }
+
+ return wantarray ? ($sql, @all_bind) : $sql;
+}
+
+sub _update_set_values {
+ my ($self, $data) = @_;
+
+ my (@set, @all_bind);
for my $k (sort keys %$data) {
my $v = $data->{$k};
my $r = ref $v;
if (@rest or not $op =~ /^\-(.+)/);
local $self->{_nested_func_lhs} = $k;
- my ($sql, @bind) = $self->_where_unary_op ($1, $arg);
+ my ($sql, @bind) = $self->_where_unary_op($1, $arg);
push @set, "$label = $sql";
push @all_bind, @bind;
}
# generate sql
- my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ')
- . join ', ', @set;
-
- if ($where) {
- my($where_sql, @where_bind) = $self->where($where);
- $sql .= $where_sql;
- push @all_bind, @where_bind;
- }
+ my $sql = join ', ', @set;
- return wantarray ? ($sql, @all_bind) : $sql;
+ return ($sql, @all_bind);
}
+# So that subclasses can override UPDATE ... RETURNING separately from
+# INSERT and DELETE
+sub _update_returning { shift->_returning(@_) }
my $where = shift;
my $order = shift;
- my($where_sql, @bind) = $self->where($where, $order);
+ my ($fields_sql, @bind) = $self->_select_fields($fields);
- my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields
- : $fields;
- my $sql = join(' ', $self->_sqlcase('select'), $f,
+ my ($where_sql, @where_bind) = $self->where($where, $order);
+ push @bind, @where_bind;
+
+ my $sql = join(' ', $self->_sqlcase('select'), $fields_sql,
$self->_sqlcase('from'), $table)
. $where_sql;
return wantarray ? ($sql, @bind) : $sql;
}
+sub _select_fields {
+ my ($self, $fields) = @_;
+ return ref $fields eq 'ARRAY' ? join ', ', map { $self->_quote($_) } @$fields
+ : $fields;
+}
+
#======================================================================
# DELETE
#======================================================================
sub delete {
- my $self = shift;
- my $table = $self->_table(shift);
- my $where = shift;
-
+ my $self = shift;
+ my $table = $self->_table(shift);
+ my $where = shift;
+ my $options = shift;
my($where_sql, @bind) = $self->where($where);
- my $sql = $self->_sqlcase('delete from') . " $table" . $where_sql;
+ my $sql = $self->_sqlcase('delete from ') . $table . $where_sql;
+
+ if ($options->{returning}) {
+ my ($returning_sql, @returning_bind) = $self->_delete_returning($options);
+ $sql .= $returning_sql;
+ push @bind, @returning_bind;
+ }
return wantarray ? ($sql, @bind) : $sql;
}
+# So that subclasses can override DELETE ... RETURNING separately from
+# INSERT and UPDATE
+sub _delete_returning { shift->_returning(@_) }
+
+
#======================================================================
# WHERE: entry point
# where ?
my ($sql, @bind) = $self->_recurse_where($where);
- $sql = $sql ? $self->_sqlcase(' where ') . "( $sql )" : '';
+ $sql = (defined $sql and length $sql) ? $self->_sqlcase(' where ') . "( $sql )" : '';
# order by?
if ($order) {
- $sql .= $self->_order_by($order);
+ my ($order_sql, @order_bind) = $self->_order_by($order);
+ $sql .= $order_sql;
+ push @bind, @order_bind;
}
return wantarray ? ($sql, @bind) : $sql;
}
+sub _expand_expr {
+ my ($self, $expr, $logic) = @_;
+ return undef unless defined($expr);
+ if (ref($expr) eq 'HASH') {
+ if (keys %$expr > 1) {
+ $logic ||= 'and';
+ return +{ -op => [
+ $logic,
+ map $self->_expand_expr_hashpair($_ => $expr->{$_}, $logic),
+ sort keys %$expr
+ ] };
+ }
+ return unless %$expr;
+ return $self->_expand_expr_hashpair(%$expr, $logic);
+ }
+ if (ref($expr) eq 'ARRAY') {
+ my $logic = lc($logic || $self->{logic});
+ $logic eq 'and' or $logic eq 'or' or puke "unknown logic: $logic";
+
+ my @expr = @$expr;
+
+ my @res;
+
+ while (my ($el) = splice @expr, 0, 1) {
+ puke "Supplying an empty left hand side argument is not supported in array-pairs"
+ unless defined($el) and length($el);
+ my $elref = ref($el);
+ if (!$elref) {
+ push(@res, $self->_expand_expr({ $el, shift(@expr) }));
+ } elsif ($elref eq 'ARRAY') {
+ push(@res, $self->_expand_expr($el)) if @$el;
+ } elsif (is_literal_value($el)) {
+ push @res, $el;
+ } elsif ($elref eq 'HASH') {
+ push @res, $self->_expand_expr($el);
+ } else {
+ die "notreached";
+ }
+ }
+ return { '-'.$logic => \@res };
+ }
+ if (my $literal = is_literal_value($expr)) {
+ return +{ -literal => $literal };
+ }
+ if (!ref($expr) or Scalar::Util::blessed($expr)) {
+ if (my $m = our $Cur_Col_Meta) {
+ return +{ -bind => [ $m, $expr ] };
+ }
+ return +{ -value => $expr };
+ }
+ die "notreached";
+}
+
+sub _expand_expr_hashpair {
+ my ($self, $k, $v, $logic) = @_;
+ unless (defined($k) and length($k)) {
+ if (defined($k) and my $literal = is_literal_value($v)) {
+ belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead';
+ return { -literal => $literal };
+ }
+ puke "Supplying an empty left hand side argument is not supported";
+ }
+ if ($k =~ /^-/) {
+ $self->_assert_pass_injection_guard($k =~ /^-(.*)$/s);
+ if ($k =~ s/ [_\s]? \d+ $//x ) {
+ belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
+ . "You probably wanted ...-and => [ $k => COND1, $k => COND2 ... ]";
+ }
+ if ($k eq '-nest') {
+ return $self->_expand_expr($v);
+ }
+ if ($k eq '-bool') {
+ if (ref($v)) {
+ return $self->_expand_expr($v);
+ }
+ puke "-bool => undef not supported" unless defined($v);
+ return { -ident => $v };
+ }
+ if ($k eq '-not') {
+ return { -op => [ 'not', $self->_expand_expr($v) ] };
+ }
+ if (my ($rest) = $k =~/^-not[_ ](.*)$/) {
+ return +{ -op => [
+ 'not',
+ $self->_expand_expr_hashpair("-${rest}", $v, $logic)
+ ] };
+ }
+ if (my ($logic) = $k =~ /^-(and|or)$/i) {
+ if (ref($v) eq 'HASH') {
+ return $self->_expand_expr($v, $logic);
+ }
+ if (ref($v) eq 'ARRAY') {
+ return $self->_expand_expr($v, $logic);
+ }
+ }
+ {
+ my $op = $k;
+ $op =~ s/^-// if length($op) > 1;
+
+ # top level special ops are illegal in general
+ puke "Illegal use of top-level '-$op'"
+ if !(defined $self->{_nested_func_lhs})
+ and List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}
+ and not List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}};
+ }
+ if ($k eq '-value' and my $m = our $Cur_Col_Meta) {
+ return +{ -bind => [ $m, $v ] };
+ }
+ if ($k eq '-op' or $k eq '-ident' or $k eq '-value' or $k eq '-bind' or $k eq '-literal' or $k eq '-func') {
+ return { $k => $v };
+ }
+ if (
+ ref($v) eq 'HASH'
+ and keys %$v == 1
+ and (keys %$v)[0] =~ /^-/
+ ) {
+ my ($func) = $k =~ /^-(.*)$/;
+ return +{ -func => [ $func, $self->_expand_expr($v) ] };
+ }
+ if (!ref($v) or is_literal_value($v)) {
+ return +{ -op => [ $k =~ /^-(.*)$/, $self->_expand_expr($v) ] };
+ }
+ }
+ if (
+ !defined($v)
+ or (
+ ref($v) eq 'HASH'
+ and exists $v->{-value}
+ and not defined $v->{-value}
+ )
+ ) {
+ return $self->_expand_expr_hashpair($k => { $self->{cmp} => undef });
+ }
+ if (!ref($v) or Scalar::Util::blessed($v)) {
+ return +{
+ -op => [
+ $self->{cmp},
+ { -ident => $k },
+ { -bind => [ $k, $v ] }
+ ]
+ };
+ }
+ if (ref($v) eq 'HASH') {
+ if (keys %$v > 1) {
+ return { -and => [
+ map $self->_expand_expr_hashpair($k => { $_ => $v->{$_} }),
+ sort keys %$v
+ ] };
+ }
+ my ($vk, $vv) = %$v;
+ $vk =~ s/^-//;
+ $vk = lc($vk);
+ $self->_assert_pass_injection_guard($vk);
+ if ($vk =~ s/ [_\s]? \d+ $//x ) {
+ belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
+ . "You probably wanted ...-and => [ -$vk => COND1, -$vk => COND2 ... ]";
+ }
+ if ($vk =~ /^(?:not[ _])?between$/) {
+ local our $Cur_Col_Meta = $k;
+ my @rhs = map $self->_expand_expr($_),
+ ref($vv) eq 'ARRAY' ? @$vv : $vv;
+ unless (
+ (@rhs == 1 and ref($rhs[0]) eq 'HASH' and $rhs[0]->{-literal})
+ or
+ (@rhs == 2 and defined($rhs[0]) and defined($rhs[1]))
+ ) {
+ puke "Operator '${\uc($vk)}' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref";
+ }
+ return +{ -op => [
+ join(' ', split '_', $vk),
+ { -ident => $k },
+ @rhs
+ ] }
+ }
+ if ($vk =~ /^(?:not[ _])?in$/) {
+ if (my $literal = is_literal_value($vv)) {
+ my ($sql, @bind) = @$literal;
+ my $opened_sql = $self->_open_outer_paren($sql);
+ return +{ -op => [
+ $vk, { -ident => $k },
+ [ { -literal => [ $opened_sql, @bind ] } ]
+ ] };
+ }
+ my $undef_err =
+ 'SQL::Abstract before v1.75 used to generate incorrect SQL when the '
+ . "-${\uc($vk)} operator was given an undef-containing list: !!!AUDIT YOUR CODE "
+ . 'AND DATA!!! (the upcoming Data::Query-based version of SQL::Abstract '
+ . 'will emit the logically correct SQL instead of raising this exception)'
+ ;
+ puke("Argument passed to the '${\uc($vk)}' operator can not be undefined")
+ if !defined($vv);
+ my @rhs = map $self->_expand_expr($_),
+ map { ref($_) ? $_ : { -bind => [ $k, $_ ] } }
+ map { defined($_) ? $_: puke($undef_err) }
+ (ref($vv) eq 'ARRAY' ? @$vv : $vv);
+ return +{
+ -literal => [ $self->{$vk =~ /^not/ ? 'sqltrue' : 'sqlfalse'} ]
+ } unless @rhs;
+
+ return +{ -op => [
+ join(' ', split '_', $vk),
+ { -ident => $k },
+ \@rhs
+ ] };
+ }
+ if ($vk eq 'ident') {
+ if (! defined $vv or ref $vv) {
+ puke "-$vk requires a single plain scalar argument (a quotable identifier)";
+ }
+ return +{ -op => [
+ $self->{cmp},
+ { -ident => $k },
+ { -ident => $vv }
+ ] };
+ }
+ if ($vk eq 'value') {
+ return $self->_expand_expr_hashpair($k, undef) unless defined($vv);
+ return +{ -op => [
+ $self->{cmp},
+ { -ident => $k },
+ { -bind => [ $k, $vv ] }
+ ] };
+ }
+ if ($vk =~ /^is(?:[ _]not)?$/) {
+ puke "$vk can only take undef as argument"
+ if defined($vv)
+ and not (
+ ref($vv) eq 'HASH'
+ and exists($vv->{-value})
+ and !defined($vv->{-value})
+ );
+ $vk =~ s/_/ /g;
+ return +{ -op => [ $vk.' null', { -ident => $k } ] };
+ }
+ if ($vk =~ /^(and|or)$/) {
+ if (ref($vv) eq 'HASH') {
+ return +{ "-${vk}" => [
+ map $self->_expand_expr_hashpair($k, { $_ => $vv->{$_} }),
+ sort keys %$vv
+ ] };
+ }
+ }
+ if (my $us = List::Util::first { $vk =~ $_->{regex} } @{$self->{user_special_ops}}) {
+ return { -op => [ $vk, { -ident => $k }, $vv ] };
+ }
+ if (ref($vv) eq 'ARRAY') {
+ my ($logic, @values) = (
+ (defined($vv->[0]) and $vv->[0] =~ /^-(and|or)$/i)
+ ? @$vv
+ : (-or => @$vv)
+ );
+ if (
+ $vk =~ $self->{inequality_op}
+ or join(' ', split '_', $vk) =~ $self->{not_like_op}
+ ) {
+ if (lc($logic) eq '-or' and @values > 1) {
+ my $op = uc join ' ', split '_', $vk;
+ belch "A multi-element arrayref as an argument to the inequality op '$op' "
+ . 'is technically equivalent to an always-true 1=1 (you probably wanted '
+ . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)"
+ ;
+ }
+ }
+ unless (@values) {
+ # try to DWIM on equality operators
+ my $op = join ' ', split '_', $vk;
+ return
+ $op =~ $self->{equality_op} ? $self->{sqlfalse}
+ : $op =~ $self->{like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqlfalse}
+ : $op =~ $self->{inequality_op} ? $self->{sqltrue}
+ : $op =~ $self->{not_like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqltrue}
+ : puke "operator '$op' applied on an empty array (field '$k')";
+ }
+ return +{ $logic => [
+ map $self->_expand_expr_hashpair($k => { $vk => $_ }),
+ @values
+ ] };
+ }
+ if (
+ !defined($vv)
+ or (
+ ref($vv) eq 'HASH'
+ and exists $vv->{-value}
+ and not defined $vv->{-value}
+ )
+ ) {
+ my $op = join ' ', split '_', $vk;
+ my $is =
+ $op =~ /^not$/i ? 'is not' # legacy
+ : $op =~ $self->{equality_op} ? 'is'
+ : $op =~ $self->{like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is'
+ : $op =~ $self->{inequality_op} ? 'is not'
+ : $op =~ $self->{not_like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is not'
+ : puke "unexpected operator '$op' with undef operand";
+ return +{ -op => [ $is.' null', { -ident => $k } ] };
+ }
+ local our $Cur_Col_Meta = $k;
+ return +{ -op => [
+ $vk,
+ { -ident => $k },
+ $self->_expand_expr($vv)
+ ] };
+ }
+ if (ref($v) eq 'ARRAY') {
+ return $self->{sqlfalse} unless @$v;
+ $self->_debug("ARRAY($k) means distribute over elements");
+ my $this_logic = (
+ $v->[0] =~ /^-((?:and|or))$/i
+ ? ($v = [ @{$v}[1..$#$v] ], $1)
+ : ($self->{logic} || 'or')
+ );
+ return +{ "-${this_logic}" => [ map $self->_expand_expr({ $k => $_ }, $this_logic), @$v ] };
+ }
+ if (my $literal = is_literal_value($v)) {
+ unless (length $k) {
+ belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead';
+ return \$literal;
+ }
+ my ($sql, @bind) = @$literal;
+ if ($self->{bindtype} eq 'columns') {
+ for (@bind) {
+ if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
+ puke "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
+ }
+ }
+ }
+ return +{ -literal => [ $self->_quote($k).' '.$sql, @bind ] };
+ }
+ die "notreached";
+}
sub _recurse_where {
my ($self, $where, $logic) = @_;
+#print STDERR Data::Dumper::Concise::Dumper([ $where, $logic ]);
+
+ my $where_exp = $self->_expand_expr($where, $logic);
+
+#print STDERR Data::Dumper::Concise::Dumper([ EXP => $where_exp ]);
+
# dispatch on appropriate method according to refkind of $where
- my $method = $self->_METHOD_FOR_refkind("_where", $where);
+ my $method = $self->_METHOD_FOR_refkind("_where", $where_exp);
- my ($sql, @bind) = $self->$method($where, $logic);
+ my ($sql, @bind) = $self->$method($where_exp, $logic);
- # DBIx::Class directly calls _recurse_where in scalar context, so
- # we must implement it, even if not in the official API
- return wantarray ? ($sql, @bind) : $sql;
+ # DBIx::Class used to call _recurse_where in scalar context
+ # something else might too...
+ if (wantarray) {
+ return ($sql, @bind);
+ }
+ else {
+ belch "Calling _recurse_where in scalar context is deprecated and will go away before 2.0";
+ return $sql;
+ }
}
my (@sql_clauses, @all_bind);
# need to use while() so can shift() for pairs
- while (my $el = shift @clauses) {
+ while (@clauses) {
+ my $el = shift @clauses;
+
+ $el = undef if (defined $el and ! length $el);
# switch according to kind of $el and get corresponding ($sql, @bind)
my ($sql, @bind) = $self->_SWITCH_refkind($el, {
SCALARREF => sub { ($$el); },
- SCALAR => sub {# top-level arrayref with scalars, recurse in pairs
- $self->_recurse_where({$el => shift(@clauses)})},
+ SCALAR => sub {
+ # top-level arrayref with scalars, recurse in pairs
+ $self->_recurse_where({$el => shift(@clauses)})
+ },
- UNDEF => sub {puke "not supported : UNDEF in arrayref" },
+ UNDEF => sub {puke "Supplying an empty left hand side argument is not supported in array-pairs" },
});
if ($sql) {
$op =~ s/^not_/NOT /i;
$self->_debug("Unary OP(-$op) within hashref, recursing...");
- my ($s, @b) = $self->_where_unary_op ($op, $v);
+ my ($s, @b) = $self->_where_unary_op($op, $v);
# top level vs nested
# we assume that handled unary ops will take care of their ()s
$s = "($s)" unless (
List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}
or
- defined($self->{_nested_func_lhs}) && ($self->{_nested_func_lhs} eq $k)
+ ( defined $self->{_nested_func_lhs} and $self->{_nested_func_lhs} eq $k )
);
($s, @b);
}
else {
+ if (! length $k) {
+ if (is_literal_value ($v) ) {
+ belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead';
+ }
+ else {
+ puke "Supplying an empty left hand side argument is not supported in hash-pairs";
+ }
+ }
+
my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
$self->$method($k, $v);
}
sub _where_unary_op {
my ($self, $op, $rhs) = @_;
- if (my $op_entry = List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}) {
+ $op =~ s/^-// if length($op) > 1;
+
+ # top level special ops are illegal in general
+ puke "Illegal use of top-level '-$op'"
+ if !(defined $self->{_nested_func_lhs})
+ and List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}
+ and not List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}};
+
+ if (my $op_entry = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
my $handler = $op_entry->{handler};
if (not ref $handler) {
belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
. "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]";
}
- return $self->$handler ($op, $rhs);
+ return $self->$handler($op, $rhs);
}
elsif (ref $handler eq 'CODE') {
return $handler->($self, $op, $rhs);
$self->_assert_pass_injection_guard($op);
- my ($sql, @bind) = $self->_SWITCH_refkind ($rhs, {
+ my ($sql, @bind) = $self->_SWITCH_refkind($rhs, {
SCALAR => sub {
- puke "Illegal use of top-level '$op'"
- unless $self->{_nested_func_lhs};
+ puke "Illegal use of top-level '-$op'"
+ unless defined $self->{_nested_func_lhs};
return (
$self->_convert('?'),
);
},
FALLBACK => sub {
- $self->_recurse_where ($rhs)
+ $self->_recurse_where($rhs)
},
});
- $sql = sprintf ('%s %s',
+ $sql = sprintf('%s %s',
$self->_sqlcase($op),
$sql,
);
},
HASHREF => sub {
- return ( $op =~ /^or/i )
- ? $self->_where_ARRAYREF( [ map { $_ => $v->{$_} } ( sort keys %$v ) ], $op )
+ return ($op =~ /^or/i)
+ ? $self->_where_ARRAYREF([ map { $_ => $v->{$_} } (sort keys %$v) ], $op)
: $self->_where_HASHREF($v);
},
},
FALLBACK => sub {
- $self->_recurse_where ($v);
+ $self->_recurse_where($v);
},
});
},
FALLBACK => sub {
- $self->_recurse_where ($v);
+ $self->_recurse_where($v);
},
});
sub _where_op_IDENT {
my $self = shift;
my ($op, $rhs) = splice @_, -2;
- if (ref $rhs) {
- puke "-$op takes a single scalar argument (a quotable identifier)";
+ if (! defined $rhs or length ref $rhs) {
+ puke "-$op requires a single plain scalar argument (a quotable identifier)";
}
# in case we are called as a top level special op (no '=')
- my $lhs = shift;
+ my $has_lhs = my $lhs = shift;
$_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
- return $lhs
+ return $has_lhs
? "$lhs = $rhs"
: $rhs
;
# in case we are called as a top level special op (no '=')
my $lhs = shift;
+ # special-case NULL
+ if (! defined $rhs) {
+ return defined $lhs
+ ? $self->_where_hashpair_HASHREF($lhs, { -is => undef })
+ : undef
+ ;
+ }
+
my @bind =
- $self->_bindtype (
- ($lhs || $self->{_nested_func_lhs}),
+ $self->_bindtype(
+ (defined $lhs ? $lhs : $self->{_nested_func_lhs}),
$rhs,
)
;
;
}
+
+my %unop_postfix = map +($_ => 1), 'is null', 'is not null';
+
+my %special = (
+ (map +($_ => do {
+ my $op = $_;
+ sub {
+ my ($self, $args) = @_;
+ my ($left, $low, $high) = @$args;
+ my ($rhsql, @rhbind) = do {
+ if (@$args == 2) {
+ puke "Single arg to between must be a literal"
+ unless $low->{-literal};
+ @{$low->{-literal}}
+ } else {
+ local $self->{_nested_func_lhs} = $left->{-ident}
+ if ref($left) eq 'HASH' and $left->{-ident};
+ my ($l, $h) = map [ $self->_where_unary_op(%$_) ], $low, $high;
+ (join(' ', $l->[0], $self->_sqlcase('and'), $h->[0]),
+ @{$l}[1..$#$l], @{$h}[1..$#$h])
+ }
+ };
+ my ($lhsql, @lhbind) = $self->_recurse_where($left);
+ return (
+ join(' ', '(', $lhsql, $self->_sqlcase($op), $rhsql, ')'),
+ @lhbind, @rhbind
+ );
+ }
+ }), 'between', 'not between'),
+ (map +($_ => do {
+ my $op = $_;
+ sub {
+ my ($self, $args) = @_;
+ my ($lhs, $rhs) = @$args;
+ my @in_bind;
+ my @in_sql = map {
+ local $self->{_nested_func_lhs} = $lhs->{-ident}
+ if ref($lhs) eq 'HASH' and $lhs->{-ident};
+ my ($sql, @bind) = $self->_where_unary_op(%$_);
+ push @in_bind, @bind;
+ $sql;
+ } @$rhs;
+ my ($lhsql, @lbind) = $self->_recurse_where($lhs);
+ return (
+ $lhsql.' '.$self->_sqlcase($op).' ( '
+ .join(', ', @in_sql)
+ .' )',
+ @lbind, @in_bind
+ );
+ }
+ }), 'in', 'not in'),
+);
+
+sub _where_op_OP {
+ my ($self, undef, $v) = @_;
+ my ($op, @args) = @$v;
+ $op =~ s/^-// if length($op) > 1;
+ local $self->{_nested_func_lhs};
+ if (my $h = $special{$op}) {
+ return $self->$h(\@args);
+ }
+ if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{user_special_ops}}) {
+ puke "Special op '${op}' requires first value to be identifier"
+ unless my ($k) = map $_->{-ident}, grep ref($_) eq 'HASH', $args[0];
+ return $self->${\($us->{handler})}($k, $op, $args[1]);
+ }
+ my $final_op = $op =~ /^(?:is|not)_/ ? join(' ', split '_', $op) : $op;
+ if (@args == 1) {
+ my ($expr_sql, @bind) = $self->_recurse_where($args[0]);
+ my $op_sql = $self->_sqlcase($final_op);
+ my $final_sql = (
+ $unop_postfix{lc($final_op)}
+ ? "${expr_sql} ${op_sql}"
+ : "${op_sql} ${expr_sql}"
+ );
+ return (($op eq 'not' ? '('.$final_sql.')' : $final_sql), @bind);
+ } else {
+ my @parts = map [ $self->_recurse_where($_) ], @args;
+ my ($final_sql) = map +($op =~ /^(and|or)$/ ? "(${_})" : $_), join(
+ ' '.$self->_sqlcase($final_op).' ',
+ map $_->[0], @parts
+ );
+ return (
+ $final_sql,
+ map @{$_}[1..$#$_], @parts
+ );
+ }
+ die "unhandled";
+}
+
+sub _where_op_FUNC {
+ my ($self, undef, $rest) = @_;
+ my ($func, @args) = @$rest;
+ my @arg_sql;
+ my @bind = map {
+ my @x = @$_;
+ push @arg_sql, shift @x;
+ @x
+ } map [ $self->_recurse_where($_) ], @args;
+ return ($self->_sqlcase($func).'('.join(', ', @arg_sql).')', @bind);
+}
+
+sub _where_op_BIND {
+ my ($self, undef, $bind) = @_;
+ return ($self->_convert('?'), $self->_bindtype(@$bind));
+}
+
+sub _where_op_LITERAL {
+ my ($self, undef, $literal) = @_;
+ $self->_assert_bindval_matches_bindtype(@{$literal}[1..$#$literal]);
+ return @$literal;
+}
+
sub _where_hashpair_ARRAYREF {
my ($self, $k, $v) = @_;
- if( @$v ) {
+ if (@$v) {
my @v = @$v; # need copy because of shift below
$self->_debug("ARRAY($k) means distribute over elements");
my ($self, $k, $v, $logic) = @_;
$logic ||= 'and';
- local $self->{_nested_func_lhs} = $self->{_nested_func_lhs};
+ local $self->{_nested_func_lhs} = defined $self->{_nested_func_lhs}
+ ? $self->{_nested_func_lhs}
+ : $k
+ ;
my ($all_sql, @all_bind);
$self->_assert_pass_injection_guard($op);
+ # fixup is_not
+ $op =~ s/^is_not/IS NOT/i;
+
# so that -not_foo works correctly
$op =~ s/^not_/NOT /i;
+ # another retarded special case: foo => { $op => { -value => undef } }
+ if (ref $val eq 'HASH' and keys %$val == 1 and exists $val->{-value} and ! defined $val->{-value} ) {
+ $val = undef;
+ }
+
my ($sql, @bind);
# CASE: col-value logic modifiers
- if ( $orig_op =~ /^ \- (and|or) $/xi ) {
+ if ($orig_op =~ /^ \- (and|or) $/xi) {
($sql, @bind) = $self->_where_hashpair_HASHREF($k, $val, $1);
}
# CASE: special operators like -in or -between
- elsif ( my $special_op = List::Util::first {$op =~ $_->{regex}} @{$self->{special_ops}} ) {
+ elsif (my $special_op = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}) {
my $handler = $special_op->{handler};
if (! $handler) {
puke "No handler supplied for special operator $orig_op";
}
elsif (not ref $handler) {
- ($sql, @bind) = $self->$handler ($k, $op, $val);
+ ($sql, @bind) = $self->$handler($k, $op, $val);
}
elsif (ref $handler eq 'CODE') {
($sql, @bind) = $handler->($self, $k, $op, $val);
UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
my $is =
- $op =~ $self->{equality_op} ? 'is'
+ $op =~ /^not$/i ? 'is not' # legacy
+ : $op =~ $self->{equality_op} ? 'is'
: $op =~ $self->{like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is'
: $op =~ $self->{inequality_op} ? 'is not'
: $op =~ $self->{not_like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is not'
},
FALLBACK => sub { # CASE: col => {op/func => $stuff}
+ ($sql, @bind) = $self->_where_unary_op($op, $val);
- # retain for proper column type bind
- $self->{_nested_func_lhs} ||= $k;
-
- ($sql, @bind) = $self->_where_unary_op ($op, $val);
-
- $sql = join (' ',
+ $sql = join(' ',
$self->_convert($self->_quote($k)),
$self->{_nested_func_lhs} eq $k ? $sql : "($sql)", # top level vs nested
);
return ($all_sql, @all_bind);
}
+sub _where_field_IS {
+ my ($self, $k, $op, $v) = @_;
+ my ($s) = $self->_SWITCH_refkind($v, {
+ UNDEF => sub {
+ join ' ',
+ $self->_convert($self->_quote($k)),
+ map { $self->_sqlcase($_)} ($op, 'null')
+ },
+ FALLBACK => sub {
+ puke "$op can only take undef as argument";
+ },
+ });
+
+ $s;
+}
sub _where_field_op_ARRAYREF {
my ($self, $k, $op, $vals) = @_;
my @vals = @$vals; #always work on a copy
- if(@vals) {
+ if (@vals) {
$self->_debug(sprintf '%s means multiple elements: [ %s ]',
$vals,
- join (', ', map { defined $_ ? "'$_'" : 'NULL' } @vals ),
+ join(', ', map { defined $_ ? "'$_'" : 'NULL' } @vals ),
);
# see if the first element is an -and/-or op
my $logic;
- if (defined $vals[0] && $vals[0] =~ /^ - ( AND|OR ) $/ix) {
+ if (defined $vals[0] && $vals[0] =~ /^ - (AND|OR) $/ix) {
$logic = uc $1;
shift @vals;
}
and
(!$logic or $logic eq 'OR')
and
- ( $op =~ $self->{inequality_op} or $op =~ $self->{not_like_op} )
+ ($op =~ $self->{inequality_op} or $op =~ $self->{not_like_op})
) {
my $o = uc($op);
belch "A multi-element arrayref as an argument to the inequality op '$o' "
sub _where_hashpair_SCALAR {
my ($self, $k, $v) = @_;
$self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v");
- my $sql = join ' ', $self->_convert($self->_quote($k)),
- $self->_sqlcase($self->{cmp}),
- $self->_convert('?');
- my @bind = $self->_bindtype($k, $v);
- return ( $sql, @bind);
+ return ($self->_where_hashpair_HASHREF($k, { $self->{cmp} => $v }));
}
sub _where_hashpair_UNDEF {
my ($self, $k, $v) = @_;
$self->_debug("UNDEF($k) means IS NULL");
- my $sql = $self->_quote($k) . $self->_sqlcase(' is null');
- return ($sql);
+ return $self->_where_hashpair_HASHREF($k, { -is => undef });
}
#======================================================================
},
HASHREF => sub {
my ($func, $arg, @rest) = %$val;
- puke ("Only simple { -func => arg } functions accepted as sub-arguments to BETWEEN")
+ puke "Only simple { -func => arg } functions accepted as sub-arguments to BETWEEN"
if (@rest or $func !~ /^ \- (.+)/x);
- local $self->{_nested_func_lhs} = $k;
- $self->_where_unary_op ($1 => $arg);
+ $self->_where_unary_op($1 => $arg);
},
FALLBACK => sub {
puke $invalid_args,
sub _where_field_IN {
my ($self, $k, $op, $vals) = @_;
- # backwards compatibility : if scalar, force into an arrayref
+ # backwards compatibility: if scalar, force into an arrayref
$vals = [$vals] if defined $vals && ! ref $vals;
my ($label) = $self->_convert($self->_quote($k));
},
HASHREF => sub {
my ($func, $arg, @rest) = %$val;
- puke ("Only simple { -func => arg } functions accepted as sub-arguments to IN")
+ puke "Only simple { -func => arg } functions accepted as sub-arguments to IN"
if (@rest or $func !~ /^ \- (.+)/x);
- local $self->{_nested_func_lhs} = $k;
- $self->_where_unary_op ($1 => $arg);
+ $self->_where_unary_op($1 => $arg);
},
UNDEF => sub {
puke(
}
return (
- sprintf ('%s %s ( %s )',
+ sprintf('%s %s ( %s )',
$label,
$op,
- join (', ', @all_sql)
+ join(', ', @all_sql)
),
$self->_bindtype($k, @all_bind),
);
}
- else { # empty list : some databases won't understand "IN ()", so DWIM
+ else { # empty list: some databases won't understand "IN ()", so DWIM
my $sql = ($op =~ /\bnot\b/i) ? $self->{sqltrue} : $self->{sqlfalse};
return ($sql);
}
},
SCALARREF => sub { # literal SQL
- my $sql = $self->_open_outer_paren ($$vals);
+ my $sql = $self->_open_outer_paren($$vals);
return ("$label $op ( $sql )");
},
ARRAYREFREF => sub { # literal SQL with bind
my ($sql, @bind) = @$$vals;
$self->_assert_bindval_matches_bindtype(@bind);
- $sql = $self->_open_outer_paren ($sql);
+ $sql = $self->_open_outer_paren($sql);
return ("$label $op ( $sql )", @bind);
},
# adding them back in the corresponding method
sub _open_outer_paren {
my ($self, $sql) = @_;
- $sql = $1 while $sql =~ /^ \s* \( (.*) \) \s* $/xs;
- return $sql;
+
+ while (my ($inner) = $sql =~ /^ \s* \( (.*) \) \s* $/xs) {
+
+ # there are closing parens inside, need the heavy duty machinery
+ # to reevaluate the extraction starting from $sql (full reevaluation)
+ if ($inner =~ /\)/) {
+ require Text::Balanced;
+
+ my (undef, $remainder) = do {
+ # idiotic design - writes to $@ but *DOES NOT* throw exceptions
+ local $@;
+ Text::Balanced::extract_bracketed($sql, '()', qr/\s*/);
+ };
+
+ # the entire expression needs to be a balanced bracketed thing
+ # (after an extract no remainder sans trailing space)
+ last if defined $remainder and $remainder =~ /\S/;
+ }
+
+ $sql = $inner;
+ }
+
+ $sql;
}
my ($self, $arg) = @_;
my (@sql, @bind);
- for my $c ($self->_order_by_chunks ($arg) ) {
- $self->_SWITCH_refkind ($c, {
+ for my $c ($self->_order_by_chunks($arg) ) {
+ $self->_SWITCH_refkind($c, {
SCALAR => sub { push @sql, $c },
ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c },
});
}
my $sql = @sql
- ? sprintf ('%s %s',
+ ? sprintf('%s %s',
$self->_sqlcase(' order by'),
- join (', ', @sql)
+ join(', ', @sql)
)
: ''
;
return $self->_SWITCH_refkind($arg, {
ARRAYREF => sub {
- map { $self->_order_by_chunks ($_ ) } @$arg;
+ map { $self->_order_by_chunks($_ ) } @$arg;
},
ARRAYREFREF => sub {
return () unless $key;
- if ( @rest or not $key =~ /^-(desc|asc)/i ) {
+ if (@rest or not $key =~ /^-(desc|asc)/i) {
puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
}
my $direction = $1;
my @ret;
- for my $c ($self->_order_by_chunks ($val)) {
+ for my $c ($self->_order_by_chunks($val)) {
my ($sql, @bind);
- $self->_SWITCH_refkind ($c, {
+ $self->_SWITCH_refkind($c, {
SCALAR => sub {
$sql = $c;
},
return '' unless defined $_[1];
return ${$_[1]} if ref($_[1]) eq 'SCALAR';
- unless ($_[0]->{quote_char}) {
- $_[0]->_assert_pass_injection_guard($_[1]);
- return $_[1];
- }
+ $_[0]->{quote_char} or
+ ($_[0]->_assert_pass_injection_guard($_[1]), return $_[1]);
my $qref = ref $_[0]->{quote_char};
- my ($l, $r);
- if (!$qref) {
- ($l, $r) = ( $_[0]->{quote_char}, $_[0]->{quote_char} );
- }
- elsif ($qref eq 'ARRAY') {
- ($l, $r) = @{$_[0]->{quote_char}};
- }
- else {
- puke "Unsupported quote_char format: $_[0]->{quote_char}";
- }
+ my ($l, $r) =
+ !$qref ? ($_[0]->{quote_char}, $_[0]->{quote_char})
+ : ($qref eq 'ARRAY') ? @{$_[0]->{quote_char}}
+ : puke "Unsupported quote_char format: $_[0]->{quote_char}";
+
+ my $esc = $_[0]->{escape_char} || $r;
# parts containing * are naturally unquoted
- return join( $_[0]->{name_sep}||'', map
- { $_ eq '*' ? $_ : $l . $_ . $r }
+ return join($_[0]->{name_sep}||'', map
+ +( $_ eq '*' ? $_ : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r } ),
( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] )
);
}
# Conversion, if applicable
-sub _convert ($) {
+sub _convert {
#my ($self, $arg) = @_;
if ($_[0]->{convert}) {
return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')';
}
# And bindtype
-sub _bindtype (@) {
+sub _bindtype {
#my ($self, $col, @vals) = @_;
# called often - tighten code
return $_[0]->{bindtype} eq 'columns'
unless ref $data eq 'HASH';
my @all_bind;
- foreach my $k ( sort keys %$data ) {
+ foreach my $k (sort keys %$data) {
my $v = $data->{$k};
$self->_SWITCH_refkind($v, {
ARRAYREF => sub {
my $sql = SQL::Abstract->new;
- my($stmt, @bind) = $sql->select($source, \@fields, \%where, \@order);
+ my($stmt, @bind) = $sql->select($source, \@fields, \%where, $order);
my($stmt, @bind) = $sql->insert($table, \%fieldvals || \@values);
$sth->execute(@bind);
# Just generate the WHERE clause
- my($stmt, @bind) = $sql->where(\%where, \@order);
+ my($stmt, @bind) = $sql->where(\%where, $order);
# Return values in the same order, for hashed queries
# See PERFORMANCE section for more details
my %data = (
name => 'Bill',
- date_entered => \["to_date(?,'MM/DD/YYYY')", "03/02/2003"],
+ date_entered => \[ "to_date(?,'MM/DD/YYYY')", "03/02/2003" ],
);
The first value in the array is the actual SQL. Any other values are
Easy, eh?
-=head1 FUNCTIONS
+=head1 METHODS
-The functions are simple. There's one for each major SQL operation,
+The methods are simple. There's one for every major SQL operation,
and a constructor you use first. The arguments are specified in a
-similar order to each function (table, then fields, then a where
+similar order for each method (table, then fields, then a where
clause) to try and simplify things.
-
-
-
=head2 new(option => 'value')
The C<new()> function takes a list of options and values, and returns
WHERE event_date >= '2/13/99' AND event_date <= '4/24/03'
The logic can also be changed locally by inserting
-a modifier in front of an arrayref :
+a modifier in front of an arrayref:
@where = (-and => [event_date => {'>=', '2/13/99'},
event_date => {'<=', '4/24/03'} ]);
sub called C<bind_fields()> or something and reuse it repeatedly. You still
get a layer of abstraction over manual SQL specification.
-Note that if you set L</bindtype> to C<columns>, the C<\[$sql, @bind]>
+Note that if you set L</bindtype> to C<columns>, the C<\[ $sql, @bind ]>
construct (see L</Literal SQL with placeholders and bind values (subqueries)>)
will expect the bind values in this format.
Quoting is useful if you have tables or columns names that are reserved
words in your database's SQL dialect.
+=item escape_char
+
+This is the character that will be used to escape L</quote_char>s appearing
+in an identifier before it has been quoted.
+
+The parameter default in case of a single L</quote_char> character is the quote
+character itself.
+
+When opening-closing-style quoting is used (L</quote_char> is an arrayref)
+this parameter defaults to the B<closing (right)> L</quote_char>. Occurrences
+of the B<opening (left)> L</quote_char> within the identifier are currently left
+untouched. The default for opening-closing-style quotes may change in future
+versions, thus you are B<strongly encouraged> to specify the escape character
+explicitly.
+
=item name_sep
This is the character that separates a table and column name. It is
=back
-=head2 update($table, \%fieldvals, \%where)
+=head2 update($table, \%fieldvals, \%where, \%options)
This takes a table, hashref of field/value pairs, and an optional
hashref L<WHERE clause|/WHERE CLAUSES>. It returns an SQL UPDATE function and a list
L</"Inserting and Updating SQL"> for information on how to insert
with those data types.
+The optional C<\%options> hash reference may contain additional
+options to generate the update SQL. Currently supported options
+are:
+
+=over 4
+
+=item returning
+
+See the C<returning> option to
+L<insert|/insert($table, \@values || \%fieldvals, \%options)>.
+
+=back
+
=head2 select($source, $fields, $where, $order)
This returns a SQL SELECT statement and associated list of bind values, as
-specified by the arguments :
+specified by the arguments:
=over
The argument can be either a plain scalar (interpreted as a table
name, will be quoted), or an arrayref (interpreted as a list
of table names, joined by commas, quoted), or a scalarref
-(literal table name, not quoted), or a ref to an arrayref
-(list of literal table names, joined by commas, not quoted).
+(literal SQL, not quoted).
=item $fields
=back
-=head2 delete($table, \%where)
+=head2 delete($table, \%where, \%options)
This takes a table name and optional hashref L<WHERE clause|/WHERE CLAUSES>.
It returns an SQL DELETE statement and list of bind values.
-=head2 where(\%where, \@order)
+The optional C<\%options> hash reference may contain additional
+options to generate the delete SQL. Currently supported options
+are:
+
+=over 4
+
+=item returning
+
+See the C<returning> option to
+L<insert|/insert($table, \@values || \%fieldvals, \%options)>.
+
+=back
+
+=head2 where(\%where, $order)
This is used to generate just the WHERE clause. For example,
if you have an arbitrary data structure and know what the
You get the idea. Strings get their case twiddled, but everything
else remains verbatim.
+=head1 EXPORTABLE FUNCTIONS
+
+=head2 is_plain_value
+
+Determines if the supplied argument is a plain value as understood by this
+module:
+
+=over
+
+=item * The value is C<undef>
+
+=item * The value is a non-reference
+
+=item * The value is an object with stringification overloading
+
+=item * The value is of the form C<< { -value => $anything } >>
+
+=back
+
+On failure returns C<undef>, on success returns a B<scalar> reference
+to the original supplied argument.
+
+=over
+
+=item * Note
+
+The stringification overloading detection is rather advanced: it takes
+into consideration not only the presence of a C<""> overload, but if that
+fails also checks for enabled
+L<autogenerated versions of C<"">|overload/Magic Autogeneration>, based
+on either C<0+> or C<bool>.
+
+Unfortunately testing in the field indicates that this
+detection B<< may tickle a latent bug in perl versions before 5.018 >>,
+but only when very large numbers of stringifying objects are involved.
+At the time of writing ( Sep 2014 ) there is no clear explanation of
+the direct cause, nor is there a manageably small test case that reliably
+reproduces the problem.
+
+If you encounter any of the following exceptions in B<random places within
+your application stack> - this module may be to blame:
+
+ Operation "ne": no method found,
+ left argument in overloaded package <something>,
+ right argument in overloaded package <something>
+
+or perhaps even
+
+ Stub found while resolving method "???" overloading """" in package <something>
+
+If you fall victim to the above - please attempt to reduce the problem
+to something that could be sent to the L<SQL::Abstract developers
+|DBIx::Class/GETTING HELP/SUPPORT>
+(either publicly or privately). As a workaround in the meantime you can
+set C<$ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}> to a true
+value, which will most likely eliminate your problem (at the expense of
+not being able to properly detect exotic forms of stringification).
+
+This notice and environment variable will be removed in a future version,
+as soon as the underlying problem is found and a reliable workaround is
+devised.
+
+=back
+
+=head2 is_literal_value
+
+Determines if the supplied argument is a literal value as understood by this
+module:
+
+=over
+
+=item * C<\$sql_string>
+
+=item * C<\[ $sql_string, @bind_values ]>
+
+=back
+
+On failure returns C<undef>, on success returns an B<array> reference
+containing the unpacked version of the supplied literal SQL and bind values.
+
=head1 WHERE CLAUSES
=head2 Introduction
@bind = ('2', '5', 'nwiger');
If you want to include literal SQL (with or without bind values), just use a
-scalar reference or array reference as the value:
+scalar reference or reference to an arrayref as the value:
my %where = (
date_entered => { '>' => \["to_date(?, 'MM/DD/YYYY')", "11/26/2008"] },
Which would generate:
- $stmt = "WHERE date_entered > "to_date(?, 'MM/DD/YYYY') AND date_expires < now()";
+ $stmt = "WHERE date_entered > to_date(?, 'MM/DD/YYYY') AND date_expires < now()";
@bind = ('11/26/2008');
Because, in Perl you I<can't> do this:
- priority => { '!=', 2, '!=', 1 }
+ priority => { '!=' => 2, '!=' => 1 }
As the second C<!=> key will obliterate the first. The solution
is to use the special C<-modifier> form inside an arrayref:
-=head2 Special operators : IN, BETWEEN, etc.
+=head2 Special operators: IN, BETWEEN, etc.
You can also use the hashref format to compare a list of fields using the
C<IN> comparison operator, by specifying the list as an arrayref:
the same way.
If the argument to C<-in> is an empty array, 'sqlfalse' is generated
-(by default : C<1=0>). Similarly, C<< -not_in => [] >> generates
-'sqltrue' (by default : C<1=1>).
+(by default: C<1=0>). Similarly, C<< -not_in => [] >> generates
+'sqltrue' (by default: C<1=1>).
In addition to the array you can supply a chunk of literal sql or
literal sql with bind:
These are the two builtin "special operators"; but the
-list can be expanded : see section L</"SPECIAL OPERATORS"> below.
+list can be expanded: see section L</"SPECIAL OPERATORS"> below.
=head2 Unary operators: bool
Clauses in hashrefs or arrayrefs can be prefixed with an C<-and> or C<-or>
-to change the logic inside :
+to change the logic inside:
my @where = (
-and => [
That would yield:
- WHERE ( user = ? AND (
- ( workhrs > ? AND geo = ? )
- OR ( workhrs < ? OR geo = ? )
- ) )
+ $stmt = "WHERE ( user = ?
+ AND ( ( workhrs > ? AND geo = ? )
+ OR ( workhrs < ? OR geo = ? ) ) )";
+ @bind = ('nwiger', '20', 'ASIA', '50', 'EURO');
=head3 Algebraic inconsistency, for historical reasons
C<Important note>: when connecting several conditions, the C<-and->|C<-or>
operator goes C<outside> of the nested structure; whereas when connecting
several constraints on one column, the C<-and> operator goes
-C<inside> the arrayref. Here is an example combining both features :
+C<inside> the arrayref. Here is an example combining both features:
my @where = (
-and => [a => 1, b => 2],
OR ( e LIKE ? AND e LIKE ? ) ) )
This difference in syntax is unfortunate but must be preserved for
-historical reasons. So be careful : the two examples below would
+historical reasons. So be careful: the two examples below would
seem algebraically equivalent, but they are not
- {col => [-and => {-like => 'foo%'}, {-like => '%bar'}]}
- # yields : WHERE ( ( col LIKE ? AND col LIKE ? ) )
+ { col => [ -and =>
+ { -like => 'foo%' },
+ { -like => '%bar' },
+ ] }
+ # yields: WHERE ( ( col LIKE ? AND col LIKE ? ) )
- [-and => {col => {-like => 'foo%'}, {col => {-like => '%bar'}}]]
- # yields : WHERE ( ( col LIKE ? OR col LIKE ? ) )
+ [ -and =>
+ { col => { -like => 'foo%' } },
+ { col => { -like => '%bar' } },
+ ]
+ # yields: WHERE ( ( col LIKE ? OR col LIKE ? ) )
=head2 Literal SQL and value type operators
in Postgres you can use something like this:
my %where = (
- date_column => \[q/= date '2008-09-30' - ?::integer/, 10/]
+ date_column => \[ "= date '2008-09-30' - ?::integer", 10 ]
)
This would create:
@bind = ('10');
Note that you must pass the bind values in the same format as they are returned
-by L</where>. That means that if you set L</bindtype> to C<columns>, you must
-provide the bind values in the C<< [ column_meta => value ] >> format, where
-C<column_meta> is an opaque scalar value; most commonly the column name, but
-you can use any scalar value (including references and blessed references),
-L<SQL::Abstract> will simply pass it through intact. So if C<bindtype> is set
-to C<columns> the above example will look like:
+by L<where|/where(\%where, $order)>. This means that if you set L</bindtype>
+to C<columns>, you must provide the bind values in the
+C<< [ column_meta => value ] >> format, where C<column_meta> is an opaque
+scalar value; most commonly the column name, but you can use any scalar value
+(including references and blessed references), L<SQL::Abstract> will simply
+pass it through intact. So if C<bindtype> is set to C<columns> the above
+example will look like:
my %where = (
- date_column => \[q/= date '2008-09-30' - ?::integer/, [ dummy => 10 ]/]
+ date_column => \[ "= date '2008-09-30' - ?::integer", [ {} => 10 ] ]
)
Literal SQL is especially useful for nesting parenthesized clauses in the
-main SQL query. Here is a first example :
+main SQL query. Here is a first example:
my ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
100, "foo%");
bar => \["IN ($sub_stmt)" => @sub_bind],
);
-This yields :
+This yields:
$stmt = "WHERE (foo = ? AND bar IN (SELECT c1 FROM t1
WHERE c2 < ? AND c3 LIKE ?))";
In the examples above, the subquery was used as an operator on a column;
but the same principle also applies for a clause within the main C<%where>
-hash, like an EXISTS subquery :
+hash, like an EXISTS subquery:
my ($sub_stmt, @sub_bind)
= $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"});
Observe that the condition on C<c2> in the subquery refers to
-column C<t0.c0> of the main query : this is I<not> a bind
+column C<t0.c0> of the main query: this is I<not> a bind
value, so we have to express it through a scalar ref.
Writing C<< c2 => {">" => "t0.c0"} >> would have generated
C<< c2 > ? >> with bind value C<"t0.c0"> ... not exactly
=head1 ORDER BY CLAUSES
Some functions take an order by clause. This can either be a scalar (just a
-column name,) a hash of C<< { -desc => 'col' } >> or C<< { -asc => 'col' } >>,
-or an array of either of the two previous forms. Examples:
-
- Given | Will Generate
- ----------------------------------------------------------
- |
- \'colA DESC' | ORDER BY colA DESC
- |
- 'colA' | ORDER BY colA
- |
- [qw/colA colB/] | ORDER BY colA, colB
- |
- {-asc => 'colA'} | ORDER BY colA ASC
- |
- {-desc => 'colB'} | ORDER BY colB DESC
- |
- ['colA', {-asc => 'colB'}] | ORDER BY colA, colB ASC
- |
- { -asc => [qw/colA colB/] } | ORDER BY colA ASC, colB ASC
- |
- [ |
- { -asc => 'colA' }, | ORDER BY colA ASC, colB DESC,
- { -desc => [qw/colB/], | colC ASC, colD ASC
- { -asc => [qw/colC colD/],|
- ] |
- ===========================================================
+column name), a hashref of C<< { -desc => 'col' } >> or C<< { -asc => 'col' }
+>>, a scalarref, an arrayref-ref, or an arrayref of any of the previous
+forms. Examples:
+
+ Given | Will Generate
+ ---------------------------------------------------------------
+ |
+ 'colA' | ORDER BY colA
+ |
+ [qw/colA colB/] | ORDER BY colA, colB
+ |
+ {-asc => 'colA'} | ORDER BY colA ASC
+ |
+ {-desc => 'colB'} | ORDER BY colB DESC
+ |
+ ['colA', {-asc => 'colB'}] | ORDER BY colA, colB ASC
+ |
+ { -asc => [qw/colA colB/] } | ORDER BY colA ASC, colB ASC
+ |
+ \'colA DESC' | ORDER BY colA DESC
+ |
+ \[ 'FUNC(colA, ?)', $x ] | ORDER BY FUNC(colA, ?)
+ | /* ...with $x bound to ? */
+ |
+ [ | ORDER BY
+ { -asc => 'colA' }, | colA ASC,
+ { -desc => [qw/colB/] }, | colB DESC,
+ { -asc => [qw/colC colD/] },| colC ASC, colD ASC,
+ \'colE DESC', | colE DESC,
+ \[ 'FUNC(colF, ?)', $x ], | FUNC(colF, ?)
+ ] | /* ...with $x bound to ? */
+ ===============================================================
A "special operator" is a SQL syntactic clause that can be
applied to a field, instead of a usual binary operator.
-For example :
+For example:
WHERE field IN (?, ?, ?)
WHERE field BETWEEN ? AND ?
the expected return is C<< ($sql, @bind) >>.
When supplied with a method name, it is simply called on the
-L<SQL::Abstract/> object as:
+L<SQL::Abstract> object as:
- $self->$method_name ($field, $op, $arg)
+ $self->$method_name($field, $op, $arg)
Where:
- $op is the part that matched the handler regex
$field is the LHS of the operator
+ $op is the part that matched the handler regex
$arg is the RHS
When supplied with a coderef, it is called as:
the expected return is C<< $sql >>.
When supplied with a method name, it is simply called on the
-L<SQL::Abstract/> object as:
+L<SQL::Abstract> object as:
- $self->$method_name ($op, $arg)
+ $self->$method_name($op, $arg)
Where:
use these three modules together to write complex database query
apps in under 50 lines.
-=head1 REPO
+=head1 HOW TO CONTRIBUTE
+
+Contributions are always welcome, in all usable forms (we especially
+welcome documentation improvements). The delivery methods include git-
+or unified-diff formatted patches, GitHub pull requests, or plain bug
+reports either via RT or the Mailing list. Contributors are generally
+granted full access to the official repository after their first several
+patches pass successful review.
+
+This project is maintained in a git repository. The code and related tools are
+accessible at the following locations:
=over
-=item * gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/SQL-Abstract.git>
+=item * Official repo: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Abstract.git>
+
+=item * Official gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/SQL-Abstract.git>
-=item * git: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Abstract.git>
+=item * GitHub mirror: L<https://github.com/dbsrgits/sql-abstract>
+
+=item * Authorized committers: L<ssh://dbsrgits@git.shadowcat.co.uk/SQL-Abstract.git>
=back
on some dark areas of C<SQL::Abstract> v1.*
B<might behave differently> in v1.50.
-The main changes are :
+The main changes are:
=over
=item *
-support for literal SQL through the C<< \ [$sql, bind] >> syntax.
+support for literal SQL through the C<< \ [ $sql, @bind ] >> syntax.
=item *
=item *
-defensive programming : check arguments
+defensive programming: check arguments
=item *
the Artistic License)
=cut
-