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.87';
# 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/^ is (?: \s+ not )? $/ix, handler => '_where_field_IS'},
-);
-
-# unaryish operators - key maps to handler
-my @BUILTIN_UNARY_OPS = (
- # the digits are backcompat stuff
- { regex => qr/^ and (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
- { regex => qr/^ or (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
- { 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 $/xi, handler => '_where_op_VALUE' },
+ {regex => qr/^ (?: not \s )? between $/ix, handler => sub { die "NOPE" }},
+ {regex => qr/^ is (?: \s+ not )? $/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" }},
);
#======================================================================
Carp::croak "[$func] Fatal: ", @_;
}
+sub is_literal_value ($) {
+ ref $_[0] eq 'SCALAR' ? [ ${$_[0]} ]
+ : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) ? [ @${ $_[0] } ]
+ : undef;
+}
+
+sub is_undef_value ($) {
+ !defined($_[0])
+ or (
+ ref($_[0]) eq 'HASH'
+ and exists $_[0]->{-value}
+ and not defined $_[0]->{-value}
+ );
+}
+
+# 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{equality_op} = qr/^( \Q$opt{cmp}\E | \= )$/ix;
$opt{inequality_op} = qr/^( != | <> )$/ix;
- $opt{like_op} = qr/^ (is\s+)? r?like $/xi;
- $opt{not_like_op} = qr/^ (is\s+)? not \s+ r?like $/xi;
+ $opt{like_op} = qr/^ (is_)?r?like $/xi;
+ $opt{not_like_op} = qr/^ (is_)?not_r?like $/xi;
# SQL booleans
$opt{sqltrue} ||= '1=1';
# special operators
$opt{special_ops} ||= [];
- # regexes are applied in order, thus push after user-defines
- push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
+
+ if ($class->isa('DBIx::Class::SQLMaker')) {
+ $opt{warn_once_on_nest} = 1;
+ $opt{disable_old_special_ops} = 1;
+ }
# unary operators
$opt{unary_ops} ||= [];
- push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS;
# rudimentary sanity-check for user supplied bits treated as functions/operators
# If a purported function matches this regular expression, an exception is thrown.
^ \s* go \s
/xmi;
+ $opt{expand_unary} = {};
+
+ $opt{expand} = {
+ not => '_expand_not',
+ bool => '_expand_bool',
+ and => '_expand_op_andor',
+ or => '_expand_op_andor',
+ nest => '_expand_nest',
+ bind => '_expand_bind',
+ in => '_expand_in',
+ not_in => '_expand_in',
+ row => '_expand_row',
+ between => '_expand_between',
+ not_between => '_expand_between',
+ op => '_expand_op',
+ (map +($_ => '_expand_op_is'), ('is', 'is_not')),
+ ident => '_expand_ident',
+ value => '_expand_value',
+ func => '_expand_func',
+ };
+
+ $opt{expand_op} = {
+ 'between' => '_expand_between',
+ 'not_between' => '_expand_between',
+ 'in' => '_expand_in',
+ 'not_in' => '_expand_in',
+ 'nest' => '_expand_nest',
+ (map +($_ => '_expand_op_andor'), ('and', 'or')),
+ (map +($_ => '_expand_op_is'), ('is', 'is_not')),
+ 'ident' => '_expand_ident',
+ 'value' => '_expand_value',
+ };
+
+ $opt{render} = {
+ (map +($_, "_render_$_"), qw(op func bind ident literal row)),
+ %{$opt{render}||{}}
+ };
+
+ $opt{render_op} = {
+ (map +($_ => '_render_op_between'), 'between', 'not_between'),
+ (map +($_ => '_render_op_in'), 'in', 'not_in'),
+ (map +($_ => '_render_unop_postfix'),
+ 'is_null', 'is_not_null', 'asc', 'desc',
+ ),
+ (not => '_render_unop_paren'),
+ (map +($_ => '_render_op_andor'), qw(and or)),
+ ',' => '_render_op_multop',
+ };
+
return bless \%opt, $class;
}
+sub sqltrue { +{ -literal => [ $_[0]->{sqltrue} ] } }
+sub sqlfalse { +{ -literal => [ $_[0]->{sqlfalse} ] } }
sub _assert_pass_injection_guard {
if ($_[1] =~ $_[0]->{injection_guard}) {
my $data = shift || return;
my $options = shift;
- my $method = $self->_METHOD_FOR_refkind("_insert", $data);
- my ($sql, @bind) = $self->$method($data);
- $sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
-
- if ($options->{returning}) {
- my ($s, @b) = $self->_insert_returning ($options);
- $sql .= $s;
- push @bind, @b;
- }
-
- return wantarray ? ($sql, @bind) : $sql;
-}
-
-sub _insert_returning {
- my ($self, $options) = @_;
-
- my $f = $options->{returning};
-
- my $fieldlist = $self->_SWITCH_refkind($f, {
- ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$f;},
- SCALAR => sub {$self->_quote($f)},
- SCALARREF => sub {$$f},
- });
- return $self->_sqlcase(' returning ') . $fieldlist;
-}
-
-sub _insert_HASHREF { # explicit list of fields and then values
- my ($self, $data) = @_;
+ my $fields;
- my @fields = sort keys %$data;
+ my ($f_aqt, $v_aqt) = $self->_expand_insert_values($data);
- my ($sql, @bind) = $self->_insert_values($data);
+ my @parts = ([ $self->_sqlcase('insert into').' '.$table ]);
+ push @parts, [ $self->render_aqt($f_aqt) ] if $f_aqt;
+ push @parts, [ $self->_sqlcase('values') ], [ $self->render_aqt($v_aqt) ];
- # assemble SQL
- $_ = $self->_quote($_) foreach @fields;
- $sql = "( ".join(", ", @fields).") ".$sql;
+ if ($options->{returning}) {
+ push @parts, [ $self->_insert_returning($options) ];
+ }
- return ($sql, @bind);
+ return $self->join_clauses(' ', @parts);
}
-sub _insert_ARRAYREF { # just generate values(?,?) part (no list of fields)
+sub _expand_insert_values {
my ($self, $data) = @_;
+ if (is_literal_value($data)) {
+ (undef, $self->expand_expr($data));
+ } else {
+ my ($fields, $values) = (
+ ref($data) eq 'HASH' ?
+ ([ sort keys %$data ], [ @{$data}{sort keys %$data} ])
+ : ([], $data)
+ );
- # no names (arrayref) so can't generate bindtype
- $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);
+ # no names (arrayref) means can't generate bindtype
+ !($fields) && $self->{bindtype} eq 'columns'
+ && belch "can't do 'columns' bindtype when called with arrayref";
+
+ +(
+ (@$fields
+ ? $self->expand_expr({ -row => $fields }, -ident)
+ : undef
+ ),
+ +{ -row => [
+ map {
+ local our $Cur_Col_Meta = $fields->[$_];
+ $self->_expand_insert_value($values->[$_])
+ } 0..$#$values
+ ] },
+ );
+ }
}
-sub _insert_ARRAYREFREF { # literal SQL with bind
- my ($self, $data) = @_;
-
- my ($sql, @bind) = @${$data};
- $self->_assert_bindval_matches_bindtype(@bind);
-
- return ($sql, @bind);
-}
+# 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) = @_;
-sub _insert_SCALARREF { # literal SQL without bind
- my ($self, $data) = @_;
+ my $f = $options->{returning};
- return ($$data);
+ my ($sql, @bind) = $self->render_aqt(
+ $self->_expand_maybe_list_expr($f, -ident)
+ );
+ return wantarray
+ ? $self->_sqlcase(' returning ') . $sql
+ : ($self->_sqlcase(' returning ').$sql, @bind);
}
-sub _insert_values {
- my ($self, $data) = @_;
-
- my (@values, @all_bind);
- foreach my $column (sort keys %$data) {
- my $v = $data->{$column};
+sub _expand_insert_value {
+ my ($self, $v) = @_;
- $self->_SWITCH_refkind($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;
- }
- },
-
- ARRAYREFREF => sub { # 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);
- },
-
- SCALARREF => sub { # literal SQL without bind
- push @values, $$v;
- },
-
- SCALAR_or_UNDEF => sub {
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- },
-
- });
+ my $k = our $Cur_Col_Meta;
+ if (ref($v) eq 'ARRAY') {
+ if ($self->{array_datatypes}) {
+ return +{ -bind => [ $k, $v ] };
+ }
+ my ($sql, @bind) = @$v;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ return +{ -literal => $v };
}
-
- my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
- return ($sql, @all_bind);
+ if (ref($v) eq 'HASH') {
+ if (grep !/^-/, keys %$v) {
+ belch "HASH ref as bind value in insert is not supported";
+ return +{ -bind => [ $k, $v ] };
+ }
+ }
+ if (!defined($v)) {
+ return +{ -bind => [ $k, undef ] };
+ }
+ return $self->expand_expr($v);
}
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';
- for my $k (sort keys %$data) {
- my $v = $data->{$k};
- my $r = ref $v;
- my $label = $self->_quote($k);
-
- $self->_SWITCH_refkind($v, {
- ARRAYREF => sub {
- if ($self->{array_datatypes}) { # array datatype
- push @set, "$label = ?";
- push @all_bind, $self->_bindtype($k, $v);
- }
- else { # literal SQL with bind
- my ($sql, @bind) = @$v;
- $self->_assert_bindval_matches_bindtype(@bind);
- push @set, "$label = $sql";
- push @all_bind, @bind;
- }
- },
- ARRAYREFREF => sub { # literal SQL with bind
- my ($sql, @bind) = @${$v};
- $self->_assert_bindval_matches_bindtype(@bind);
- push @set, "$label = $sql";
- push @all_bind, @bind;
- },
- SCALARREF => sub { # literal SQL without bind
- push @set, "$label = $$v";
- },
- HASHREF => sub {
- my ($op, $arg, @rest) = %$v;
-
- puke 'Operator calls in update must be in the form { -op => $arg }'
- if (@rest or not $op =~ /^\-(.+)/);
-
- local $self->{_nested_func_lhs} = $k;
- my ($sql, @bind) = $self->_where_unary_op ($1, $arg);
-
- push @set, "$label = $sql";
- push @all_bind, @bind;
- },
- SCALAR_or_UNDEF => sub {
- push @set, "$label = ?";
- push @all_bind, $self->_bindtype($k, $v);
- },
- });
- }
-
- # generate sql
- my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ')
- . join ', ', @set;
+ 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);
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) = @_;
+
+ return $self->render_aqt(
+ $self->_expand_update_set_values(undef, $data),
+ );
+}
+
+sub _expand_update_set_values {
+ my ($self, undef, $data) = @_;
+ $self->_expand_maybe_list_expr( [
+ map {
+ my ($k, $set) = @$_;
+ $set = { -bind => $_ } unless defined $set;
+ +{ -op => [ '=', $self->_expand_ident(-ident => $k), $set ] };
+ }
+ map {
+ my $k = $_;
+ my $v = $data->{$k};
+ (ref($v) eq 'ARRAY'
+ ? ($self->{array_datatypes}
+ ? [ $k, +{ -bind => [ $k, $v ] } ]
+ : [ $k, +{ -literal => $v } ])
+ : do {
+ local our $Cur_Col_Meta = $k;
+ [ $k, $self->_expand_expr($v) ]
+ }
+ );
+ } sort keys %$data
+ ] );
+}
+
+# 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 ($where_sql, @where_bind) = $self->where($where, $order);
+ push @bind, @where_bind;
- my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields
- : $fields;
- my $sql = join(' ', $self->_sqlcase('select'), $f,
+ 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 $fields unless ref($fields);
+ return $self->render_aqt(
+ $self->_expand_maybe_list_expr($fields, '-ident')
+ );
+}
+
#======================================================================
# 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
sub where {
my ($self, $where, $order) = @_;
+ local $self->{convert_where} = $self->{convert};
+
# where ?
- my ($sql, @bind) = $self->_recurse_where($where);
- $sql = $sql ? $self->_sqlcase(' where ') . "( $sql )" : '';
+ my ($sql, @bind) = defined($where)
+ ? $self->_recurse_where($where)
+ : (undef);
+ $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;
}
+{ our $Default_Scalar_To = -value }
-sub _recurse_where {
- my ($self, $where, $logic) = @_;
-
- # dispatch on appropriate method according to refkind of $where
- my $method = $self->_METHOD_FOR_refkind("_where", $where);
-
- my ($sql, @bind) = $self->$method($where, $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;
+sub expand_expr {
+ my ($self, $expr, $default_scalar_to) = @_;
+ local our $Default_Scalar_To = $default_scalar_to if $default_scalar_to;
+ $self->_expand_expr($expr);
}
+sub render_aqt {
+ my ($self, $aqt) = @_;
+ my ($k, $v, @rest) = %$aqt;
+ die "No" if @rest;
+ die "Not a node type: $k" unless $k =~ s/^-//;
+ if (my $meth = $self->{render}{$k}) {
+ return $self->$meth($k, $v);
+ }
+ die "notreached: $k";
+}
+sub render_expr {
+ my ($self, $expr, $default_scalar_to) = @_;
+ my ($sql, @bind) = $self->render_aqt(
+ $self->expand_expr($expr, $default_scalar_to)
+ );
+ return (wantarray ? ($sql, @bind) : $sql);
+}
-#======================================================================
-# WHERE: top-level ARRAYREF
-#======================================================================
-
-
-sub _where_ARRAYREF {
- my ($self, $where, $logic) = @_;
-
- $logic = uc($logic || $self->{logic});
- $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic";
-
- my @clauses = @$where;
-
- my (@sql_clauses, @all_bind);
- # need to use while() so can shift() for pairs
- while (my $el = shift @clauses) {
-
- # switch according to kind of $el and get corresponding ($sql, @bind)
- my ($sql, @bind) = $self->_SWITCH_refkind($el, {
-
- # skip empty elements, otherwise get invalid trailing AND stuff
- ARRAYREF => sub {$self->_recurse_where($el) if @$el},
+sub _normalize_op {
+ my ($self, $raw) = @_;
+ s/^-(?=.)//, s/\s+/_/g for my $op = lc $raw;
+ $op;
+}
- ARRAYREFREF => sub {
- my ($s, @b) = @$$el;
- $self->_assert_bindval_matches_bindtype(@b);
- ($s, @b);
- },
+sub _expand_expr {
+ my ($self, $expr) = @_;
+ our $Expand_Depth ||= 0; local $Expand_Depth = $Expand_Depth + 1;
+ return undef unless defined($expr);
+ if (ref($expr) eq 'HASH') {
+ return undef unless my $kc = keys %$expr;
+ if ($kc > 1) {
+ return $self->_expand_op_andor(and => $expr);
+ }
+ my ($key, $value) = %$expr;
+ if ($key =~ /^-/ and $key =~ 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 => [ $key => COND1, $key => COND2 ... ]";
+ }
+ return $self->_expand_hashpair($key, $value);
+ }
+ if (ref($expr) eq 'ARRAY') {
+ return $self->_expand_op_andor(lc($self->{logic}), $expr);
+ }
+ if (my $literal = is_literal_value($expr)) {
+ return +{ -literal => $literal };
+ }
+ if (!ref($expr) or Scalar::Util::blessed($expr)) {
+ return $self->_expand_scalar($expr);
+ }
+ die "notreached";
+}
- HASHREF => sub {$self->_recurse_where($el, 'and') if %$el},
+sub _expand_hashpair {
+ my ($self, $k, $v) = @_;
+ 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 =~ /^-/) {
+ return $self->_expand_hashpair_op($k, $v);
+ } elsif ($k =~ /^[^\w]/i) {
+ my ($lhs, @rhs) = @$v;
+ return $self->_expand_op(
+ -op, [ $k, $self->expand_expr($lhs, -ident), @rhs ]
+ );
+ }
+ return $self->_expand_hashpair_ident($k, $v);
+}
- SCALARREF => sub { ($$el); },
+sub _expand_hashpair_ident {
+ my ($self, $k, $v) = @_;
- SCALAR => sub {# top-level arrayref with scalars, recurse in pairs
- $self->_recurse_where({$el => shift(@clauses)})},
+ local our $Cur_Col_Meta = $k;
- UNDEF => sub {puke "not supported : UNDEF in arrayref" },
- });
+ # hash with multiple or no elements is andor
- if ($sql) {
- push @sql_clauses, $sql;
- push @all_bind, @bind;
- }
+ if (ref($v) eq 'HASH' and keys %$v != 1) {
+ return $self->_expand_op_andor(and => $v, $k);
}
- return $self->_join_sql_clauses($logic, \@sql_clauses, \@all_bind);
-}
+ # undef needs to be re-sent with cmp to achieve IS/IS NOT NULL
-#======================================================================
-# WHERE: top-level ARRAYREFREF
-#======================================================================
+ if (is_undef_value($v)) {
+ return $self->_expand_hashpair_cmp($k => undef);
+ }
-sub _where_ARRAYREFREF {
- my ($self, $where) = @_;
- my ($sql, @bind) = @$$where;
- $self->_assert_bindval_matches_bindtype(@bind);
- return ($sql, @bind);
-}
+ # scalars and objects get expanded as whatever requested or values
-#======================================================================
-# WHERE: top-level HASHREF
-#======================================================================
+ if (!ref($v) or Scalar::Util::blessed($v)) {
+ return $self->_expand_hashpair_scalar($k, $v);
+ }
-sub _where_HASHREF {
- my ($self, $where) = @_;
- my (@sql_clauses, @all_bind);
-
- for my $k (sort keys %$where) {
- my $v = $where->{$k};
-
- # ($k => $v) is either a special unary op or a regular hashpair
- my ($sql, @bind) = do {
- if ($k =~ /^-./) {
- # put the operator in canonical form
- my $op = $k;
- $op = substr $op, 1; # remove initial dash
- $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
- $op =~ s/\s+/ /g; # compress whitespace
-
- # so that -not_foo works correctly
- $op =~ s/^not_/NOT /i;
-
- $self->_debug("Unary OP(-$op) within hashref, recursing...");
- 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)
- );
- ($s, @b);
- }
- else {
- my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
- $self->$method($k, $v);
- }
- };
+ # single key hashref is a hashtriple
- push @sql_clauses, $sql;
- push @all_bind, @bind;
+ if (ref($v) eq 'HASH') {
+ return $self->_expand_hashtriple($k, %$v);
}
- return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind);
-}
-
-sub _where_unary_op {
- my ($self, $op, $rhs) = @_;
+ # arrayref needs re-engineering over the elements
- if (my $op_entry = List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}) {
- my $handler = $op_entry->{handler};
+ if (ref($v) eq 'ARRAY') {
+ return $self->sqlfalse unless @$v;
+ $self->_debug("ARRAY($k) means distribute over elements");
+ my $logic = lc(
+ $v->[0] =~ /^-(and|or)$/i
+ ? (shift(@{$v = [ @$v ]}), $1)
+ : lc($self->{logic} || 'OR')
+ );
+ return $self->_expand_op_andor(
+ $logic => $v, $k
+ );
+ }
- if (not ref $handler) {
- if ($op =~ 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 => [ -$op => COND1, -$op => COND2 ... ]";
- }
- return $self->$handler ($op, $rhs);
- }
- elsif (ref $handler eq 'CODE') {
- return $handler->($self, $op, $rhs);
+ 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;
}
- else {
- puke "Illegal handler for operator $op - expecting a method name or a coderef";
+ my ($sql, @bind) = @$literal;
+ if ($self->{bindtype} eq 'columns') {
+ for (@bind) {
+ $self->_assert_bindval_matches_bindtype($_);
+ }
}
+ return +{ -literal => [ $self->_quote($k).' '.$sql, @bind ] };
}
+ die "notreached";
+}
- $self->_debug("Generic unary OP: $op - recursing as function");
+sub _expand_scalar {
+ my ($self, $expr) = @_;
- $self->_assert_pass_injection_guard($op);
+ return $self->_expand_expr({ (our $Default_Scalar_To) => $expr });
+}
- my ($sql, @bind) = $self->_SWITCH_refkind ($rhs, {
- SCALAR => sub {
- puke "Illegal use of top-level '$op'"
- unless $self->{_nested_func_lhs};
+sub _expand_hashpair_scalar {
+ my ($self, $k, $v) = @_;
- return (
- $self->_convert('?'),
- $self->_bindtype($self->{_nested_func_lhs}, $rhs)
- );
- },
- FALLBACK => sub {
- $self->_recurse_where ($rhs)
- },
- });
-
- $sql = sprintf ('%s %s',
- $self->_sqlcase($op),
- $sql,
+ return $self->_expand_hashpair_cmp(
+ $k, $self->_expand_scalar($v),
);
-
- return ($sql, @bind);
}
-sub _where_op_ANDOR {
- my ($self, $op, $v) = @_;
-
- $self->_SWITCH_refkind($v, {
- ARRAYREF => sub {
- return $self->_where_ARRAYREF($v, $op);
- },
-
- HASHREF => sub {
- return ( $op =~ /^or/i )
- ? $self->_where_ARRAYREF( [ map { $_ => $v->{$_} } ( sort keys %$v ) ], $op )
- : $self->_where_HASHREF($v);
- },
-
- SCALARREF => sub {
- puke "-$op => \\\$scalar makes little sense, use " .
- ($op =~ /^or/i
- ? '[ \$scalar, \%rest_of_conditions ] instead'
- : '-and => [ \$scalar, \%rest_of_conditions ] instead'
- );
- },
-
- ARRAYREFREF => sub {
- puke "-$op => \\[...] makes little sense, use " .
- ($op =~ /^or/i
- ? '[ \[...], \%rest_of_conditions ] instead'
- : '-and => [ \[...], \%rest_of_conditions ] instead'
- );
- },
-
- SCALAR => sub { # permissively interpreted as SQL
- puke "-$op => \$value makes little sense, use -bool => \$value instead";
- },
-
- UNDEF => sub {
- puke "-$op => undef not supported";
- },
- });
-}
-
-sub _where_op_NEST {
- my ($self, $op, $v) = @_;
-
- $self->_SWITCH_refkind($v, {
-
- SCALAR => sub { # permissively interpreted as SQL
- belch "literal SQL should be -nest => \\'scalar' "
- . "instead of -nest => 'scalar' ";
- return ($v);
- },
+sub _expand_hashpair_op {
+ my ($self, $k, $v) = @_;
- UNDEF => sub {
- puke "-$op => undef not supported";
- },
+ $self->_assert_pass_injection_guard($k =~ /\A-(.*)\Z/s);
- FALLBACK => sub {
- $self->_recurse_where ($v);
- },
+ my $op = $self->_normalize_op($k);
- });
-}
+ if (my $exp = $self->{expand}{$op}) {
+ return $self->$exp($op, $v);
+ }
+ # Ops prefixed with -not_ get converted
-sub _where_op_BOOL {
- my ($self, $op, $v) = @_;
+ if (my ($rest) = $op =~/^not_(.*)$/) {
+ return +{ -op => [
+ 'not',
+ $self->_expand_expr({ "-${rest}", $v })
+ ] };
+ }
- my ($s, @b) = $self->_SWITCH_refkind($v, {
- SCALAR => sub { # interpreted as SQL column
- $self->_convert($self->_quote($v));
- },
+ { # Old SQLA compat
- UNDEF => sub {
- puke "-$op => undef not supported";
- },
+ my $op = join(' ', split '_', $op);
- FALLBACK => sub {
- $self->_recurse_where ($v);
- },
- });
+ # the old special op system requires illegality for top-level use
- $s = "(NOT $s)" if $op =~ /^not/i;
- ($s, @b);
-}
+ if (
+ (our $Expand_Depth) == 1
+ and (
+ List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}
+ or (
+ $self->{disable_old_special_ops}
+ and List::Util::first { $op =~ $_->{regex} } @BUILTIN_SPECIAL_OPS
+ )
+ )
+ ) {
+ puke "Illegal use of top-level '-$op'"
+ }
+ # the old unary op system means we should touch nothing and let it work
-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 (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
+ return { -op => [ $op, $v ] };
+ }
}
- # in case we are called as a top level special op (no '=')
- my $lhs = shift;
-
- $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
+ # an explicit node type is currently assumed to be expanded (this is almost
+ # certainly wrong and there should be expansion anyway)
- return $lhs
- ? "$lhs = $rhs"
- : $rhs
- ;
-}
+ if ($self->{render}{$op}) {
+ return { $k => $v };
+ }
-sub _where_op_VALUE {
- my $self = shift;
- my ($op, $rhs) = splice @_, -2;
+ my $type = $self->{unknown_unop_always_func} ? -func : -op;
- # in case we are called as a top level special op (no '=')
- my $lhs = shift;
+ { # Old SQLA compat
- my @bind =
- $self->_bindtype (
- ($lhs || $self->{_nested_func_lhs}),
- $rhs,
- )
- ;
+ if (
+ ref($v) eq 'HASH'
+ and keys %$v == 1
+ and (keys %$v)[0] =~ /^-/
+ ) {
+ $type = (
+ (List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}})
+ ? -op
+ : -func
+ )
+ }
+ }
- return $lhs
- ? (
- $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
- @bind
- )
- : (
- $self->_convert('?'),
- @bind,
- )
- ;
+ return +{ $type => [
+ $op,
+ ($type eq -func and ref($v) eq 'ARRAY')
+ ? map $self->_expand_expr($_), @$v
+ : $self->_expand_expr($v)
+ ] };
}
-sub _where_hashpair_ARRAYREF {
+sub _expand_hashpair_cmp {
my ($self, $k, $v) = @_;
+ $self->_expand_hashtriple($k, $self->{cmp}, $v);
+}
- if( @$v ) {
- my @v = @$v; # need copy because of shift below
- $self->_debug("ARRAY($k) means distribute over elements");
+sub _expand_hashtriple {
+ my ($self, $k, $vk, $vv) = @_;
- # put apart first element if it is an operator (-and, -or)
- my $op = (
- (defined $v[0] && $v[0] =~ /^ - (?: AND|OR ) $/ix)
- ? shift @v
- : ''
- );
- my @distributed = map { {$k => $_} } @v;
+ my $ik = $self->_expand_ident(-ident => $k);
- if ($op) {
- $self->_debug("OP($op) reinjected into the distributed array");
- unshift @distributed, $op;
- }
+ my $op = $self->_normalize_op($vk);
+ $self->_assert_pass_injection_guard($op);
- my $logic = $op ? substr($op, 1) : '';
+ if ($op =~ s/ _? \d+ $//x ) {
+ return $self->_expand_expr($k, { $vk, $vv });
+ }
+ if (my $x = $self->{expand_op}{$op}) {
+ local our $Cur_Col_Meta = $k;
+ return $self->$x($op, $vv, $k);
+ }
+ { # Old SQLA compat
- return $self->_recurse_where(\@distributed, $logic);
+ my $op = join(' ', split '_', $op);
+
+ if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}) {
+ return { -op => [ $op, $ik, $vv ] };
+ }
+ if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
+ return { -op => [
+ $self->{cmp},
+ $ik,
+ { -op => [ $op, $vv ] }
+ ] };
+ }
}
- else {
- $self->_debug("empty ARRAY($k) means 0=1");
- return ($self->{sqlfalse});
+ if (ref($vv) eq 'ARRAY') {
+ my @raw = @$vv;
+ my $logic = (defined($raw[0]) and $raw[0] =~ /^-(and|or)$/i)
+ ? (shift(@raw), $1) : 'or';
+ my @values = map +{ $vk => $_ }, @raw;
+ if (
+ $op =~ $self->{inequality_op}
+ or $op =~ $self->{not_like_op}
+ ) {
+ if (lc($logic) eq 'or' and @values > 1) {
+ belch "A multi-element arrayref as an argument to the inequality op '${\uc(join ' ', split '_', $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
+ return ($self->_dwim_op_to_is($op,
+ "Supplying an empty arrayref to '%s' is deprecated",
+ "operator '%s' applied on an empty array (field '$k')"
+ ) ? $self->sqlfalse : $self->sqltrue);
+ }
+ return $self->_expand_op_andor($logic => \@values, $k);
+ }
+ if (is_undef_value($vv)) {
+ my $is = ($self->_dwim_op_to_is($op,
+ "Supplying an undefined argument to '%s' is deprecated",
+ "unexpected operator '%s' with undef operand",
+ ) ? 'is' : 'is not');
+
+ return $self->_expand_hashpair($k => { $is, undef });
}
+ local our $Cur_Col_Meta = $k;
+ return +{ -op => [
+ $op,
+ $ik,
+ $self->_expand_expr($vv)
+ ] };
}
-sub _where_hashpair_HASHREF {
- my ($self, $k, $v, $logic) = @_;
- $logic ||= 'and';
+sub _dwim_op_to_is {
+ my ($self, $raw, $empty, $fail) = @_;
- local $self->{_nested_func_lhs} = $self->{_nested_func_lhs};
+ my $op = $self->_normalize_op($raw);
- my ($all_sql, @all_bind);
+ if ($op =~ /^not$/i) {
+ return 0;
+ }
+ if ($op =~ $self->{equality_op}) {
+ return 1;
+ }
+ if ($op =~ $self->{like_op}) {
+ belch(sprintf $empty, uc(join ' ', split '_', $op));
+ return 1;
+ }
+ if ($op =~ $self->{inequality_op}) {
+ return 0;
+ }
+ if ($op =~ $self->{not_like_op}) {
+ belch(sprintf $empty, uc(join ' ', split '_', $op));
+ return 0;
+ }
+ puke(sprintf $fail, $op);
+}
- for my $orig_op (sort keys %$v) {
- my $val = $v->{$orig_op};
+sub _expand_func {
+ my ($self, undef, $args) = @_;
+ my ($func, @args) = @$args;
+ return { -func => [ $func, map $self->expand_expr($_), @args ] };
+}
- # put the operator in canonical form
- my $op = $orig_op;
+sub _expand_ident {
+ my ($self, undef, $body, $k) = @_;
+ return $self->_expand_hashpair_cmp(
+ $k, { -ident => $body }
+ ) if defined($k);
+ unless (defined($body) or (ref($body) and ref($body) eq 'ARRAY')) {
+ puke "-ident requires a single plain scalar argument (a quotable identifier) or an arrayref of identifier parts";
+ }
+ my @parts = map split(/\Q${\($self->{name_sep}||'.')}\E/, $_),
+ ref($body) ? @$body : $body;
+ return { -ident => $parts[-1] } if $self->{_dequalify_idents};
+ unless ($self->{quote_char}) {
+ $self->_assert_pass_injection_guard($_) for @parts;
+ }
+ return +{ -ident => \@parts };
+}
- # FIXME - we need to phase out dash-less ops
- $op =~ s/^-//; # remove possible initial dash
- $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
- $op =~ s/\s+/ /g; # compress whitespace
+sub _expand_value {
+ return $_[0]->_expand_hashpair_cmp(
+ $_[3], { -value => $_[2] },
+ ) if defined($_[3]);
+ +{ -bind => [ our $Cur_Col_Meta, $_[2] ] };
+}
- $self->_assert_pass_injection_guard($op);
+sub _expand_not {
+ +{ -op => [ 'not', $_[0]->_expand_expr($_[2]) ] };
+}
- # fixup is_not
- $op =~ s/^is_not/IS NOT/i;
+sub _expand_row {
+ my ($self, undef, $args) = @_;
+ +{ -row => [ map $self->expand_expr($_), @$args ] };
+}
- # so that -not_foo works correctly
- $op =~ s/^not_/NOT /i;
+sub _expand_op {
+ my ($self, undef, $args) = @_;
+ my ($op, @opargs) = @$args;
+ if (my $exp = $self->{expand_op}{$op}) {
+ return $self->$exp($op, \@opargs);
+ }
+ +{ -op => [ $op, map $self->expand_expr($_), @opargs ] };
+}
- my ($sql, @bind);
+sub _expand_bool {
+ my ($self, undef, $v) = @_;
+ if (ref($v)) {
+ return $self->_expand_expr($v);
+ }
+ puke "-bool => undef not supported" unless defined($v);
+ return $self->_expand_ident(-ident => $v);
+}
- # CASE: col-value logic modifiers
- 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}} ) {
- 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);
- }
- elsif (ref $handler eq 'CODE') {
- ($sql, @bind) = $handler->($self, $k, $op, $val);
- }
- else {
- puke "Illegal handler for special operator $orig_op - expecting a method name or a coderef";
+sub _expand_op_andor {
+ my ($self, $logop, $v, $k) = @_;
+ if (defined $k) {
+ $v = [ map +{ $k, $_ },
+ (ref($v) eq 'HASH')
+ ? (map +{ $_ => $v->{$_} }, sort keys %$v)
+ : @$v,
+ ];
+ }
+ if (ref($v) eq 'HASH') {
+ return undef unless keys %$v;
+ return +{ -op => [
+ $logop,
+ map $self->_expand_expr({ $_ => $v->{$_} }),
+ sort keys %$v
+ ] };
+ }
+ if (ref($v) eq 'ARRAY') {
+ $logop eq 'and' or $logop eq 'or' or puke "unknown logic: $logop";
+
+ my @expr = grep {
+ (ref($_) eq 'ARRAY' and @$_)
+ or (ref($_) eq 'HASH' and %$_)
+ or 1
+ } @$v;
+
+ 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) {
+ local our $Expand_Depth = 0;
+ push(@res, grep defined, $self->_expand_expr({ $el, shift(@expr) }));
+ } elsif ($elref eq 'ARRAY') {
+ push(@res, grep defined, $self->_expand_expr($el)) if @$el;
+ } elsif (my $l = is_literal_value($el)) {
+ push @res, { -literal => $l };
+ } elsif ($elref eq 'HASH') {
+ local our $Expand_Depth = 0;
+ push @res, grep defined, $self->_expand_expr($el) if %$el;
+ } else {
+ die "notreached";
}
}
- else {
- $self->_SWITCH_refkind($val, {
-
- ARRAYREF => sub { # CASE: col => {op => \@vals}
- ($sql, @bind) = $self->_where_field_op_ARRAYREF($k, $op, $val);
- },
-
- ARRAYREFREF => sub { # CASE: col => {op => \[$sql, @bind]} (literal SQL with bind)
- my ($sub_sql, @sub_bind) = @$$val;
- $self->_assert_bindval_matches_bindtype(@sub_bind);
- $sql = join ' ', $self->_convert($self->_quote($k)),
- $self->_sqlcase($op),
- $sub_sql;
- @bind = @sub_bind;
- },
-
- UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
- my $is =
- $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 '$orig_op' with undef operand";
-
- $sql = $self->_quote($k) . $self->_sqlcase(" $is null");
- },
+ # ???
+ # return $res[0] if @res == 1;
+ return { -op => [ $logop, @res ] };
+ }
+ die "notreached";
+}
- FALLBACK => sub { # CASE: col => {op/func => $stuff}
+sub _expand_op_is {
+ my ($self, $op, $vv, $k) = @_;
+ ($k, $vv) = @$vv unless defined $k;
+ puke "$op can only take undef as argument"
+ if defined($vv)
+ and not (
+ ref($vv) eq 'HASH'
+ and exists($vv->{-value})
+ and !defined($vv->{-value})
+ );
+ return +{ -op => [ $op.'_null', $self->expand_expr($k, -ident) ] };
+}
- # retain for proper column type bind
- $self->{_nested_func_lhs} ||= $k;
+sub _expand_between {
+ my ($self, $op, $vv, $k) = @_;
+ $k = shift @{$vv = [ @$vv ]} unless defined $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($op)}' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref";
+ }
+ return +{ -op => [
+ $op,
+ $self->expand_expr(ref($k) ? $k : { -ident => $k }),
+ @rhs
+ ] }
+}
- ($sql, @bind) = $self->_where_unary_op ($op, $val);
+sub _expand_in {
+ my ($self, $op, $vv, $k) = @_;
+ $k = shift @{$vv = [ @$vv ]} unless defined $k;
+ if (my $literal = is_literal_value($vv)) {
+ my ($sql, @bind) = @$literal;
+ my $opened_sql = $self->_open_outer_paren($sql);
+ return +{ -op => [
+ $op, $self->expand_expr($k, -ident),
+ { -literal => [ $opened_sql, @bind ] }
+ ] };
+ }
+ my $undef_err =
+ 'SQL::Abstract before v1.75 used to generate incorrect SQL when the '
+ . "-${\uc($op)} 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($op)}' operator can not be undefined")
+ if !defined($vv);
+ my @rhs = map $self->expand_expr($_, -value),
+ map { defined($_) ? $_: puke($undef_err) }
+ (ref($vv) eq 'ARRAY' ? @$vv : $vv);
+ return $self->${\($op =~ /^not/ ? 'sqltrue' : 'sqlfalse')} unless @rhs;
+
+ return +{ -op => [
+ $op,
+ $self->expand_expr($k, -ident),
+ @rhs
+ ] };
+}
- $sql = join (' ',
- $self->_convert($self->_quote($k)),
- $self->{_nested_func_lhs} eq $k ? $sql : "($sql)", # top level vs nested
- );
- },
- });
+sub _expand_nest {
+ my ($self, undef, $v) = @_;
+ # DBIx::Class requires a nest warning to be emitted once but the private
+ # method it overrode to do so no longer exists
+ if ($self->{warn_once_on_nest}) {
+ unless (our $Nest_Warned) {
+ belch(
+ "-nest in search conditions is deprecated, you most probably wanted:\n"
+ .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
+ );
+ $Nest_Warned = 1;
}
-
- ($all_sql) = (defined $all_sql and $all_sql) ? $self->_join_sql_clauses($logic, [$all_sql, $sql], []) : $sql;
- push @all_bind, @bind;
}
- return ($all_sql, @all_bind);
+ return $self->_expand_expr($v);
}
-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 _expand_bind {
+ my ($self, undef, $bind) = @_;
+ return { -bind => $bind };
}
-sub _where_field_op_ARRAYREF {
- my ($self, $k, $op, $vals) = @_;
-
- my @vals = @$vals; #always work on a copy
+sub _recurse_where {
+ my ($self, $where, $logic) = @_;
- if(@vals) {
- $self->_debug(sprintf '%s means multiple elements: [ %s ]',
- $vals,
- join (', ', map { defined $_ ? "'$_'" : 'NULL' } @vals ),
- );
+ # Special case: top level simple string treated as literal
- # see if the first element is an -and/-or op
- my $logic;
- if (defined $vals[0] && $vals[0] =~ /^ - ( AND|OR ) $/ix) {
- $logic = uc $1;
- shift @vals;
- }
-
- # a long standing API wart - an attempt to change this behavior during
- # the 1.50 series failed *spectacularly*. Warn instead and leave the
- # behavior as is
- if (
- @vals > 1
- and
- (!$logic or $logic eq 'OR')
- and
- ( $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' "
- . 'is technically equivalent to an always-true 1=1 (you probably wanted '
- . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)"
- ;
- }
+ my $where_exp = (ref($where)
+ ? $self->_expand_expr($where, $logic)
+ : { -literal => [ $where ] });
- # distribute $op over each remaining member of @vals, append logic if exists
- return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic);
+ # dispatch expanded expression
+ my ($sql, @bind) = defined($where_exp) ? $self->render_aqt($where_exp) : (undef);
+ # DBIx::Class used to call _recurse_where in scalar context
+ # something else might too...
+ if (wantarray) {
+ return ($sql, @bind);
}
else {
- # try to DWIM on equality operators
- 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')";
+ belch "Calling _recurse_where in scalar context is deprecated and will go away before 2.0";
+ return $sql;
}
}
+sub _render_ident {
+ my ($self, undef, $ident) = @_;
-sub _where_hashpair_SCALARREF {
- my ($self, $k, $v) = @_;
- $self->_debug("SCALAR($k) means literal SQL: $$v");
- my $sql = $self->_quote($k) . " " . $$v;
- return ($sql);
+ return $self->_convert($self->_quote($ident));
}
-# literal SQL with bind
-sub _where_hashpair_ARRAYREFREF {
- my ($self, $k, $v) = @_;
- $self->_debug("REF($k) means literal SQL: @${$v}");
- my ($sql, @bind) = @$$v;
- $self->_assert_bindval_matches_bindtype(@bind);
- $sql = $self->_quote($k) . " " . $sql;
- return ($sql, @bind );
+sub _render_row {
+ my ($self, undef, $values) = @_;
+ my ($sql, @bind) = $self->_render_op(undef, [ ',', @$values ]);
+ return "($sql)", @bind;
}
-# literal SQL without bind
-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);
+sub _render_func {
+ my ($self, undef, $rest) = @_;
+ my ($func, @args) = @$rest;
+ if (ref($func) eq 'HASH') {
+ $func = $self->render_aqt($func);
+ }
+ my @arg_sql;
+ my @bind = map {
+ my @x = @$_;
+ push @arg_sql, shift @x;
+ @x
+ } map [ $self->render_aqt($_) ], @args;
+ return ($self->_sqlcase($func).'('.join(', ', @arg_sql).')', @bind);
}
+sub _render_bind {
+ my ($self, undef, $bind) = @_;
+ return ($self->_convert('?'), $self->_bindtype(@$bind));
+}
-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);
+sub _render_literal {
+ my ($self, undef, $literal) = @_;
+ $self->_assert_bindval_matches_bindtype(@{$literal}[1..$#$literal]);
+ return @$literal;
}
-#======================================================================
-# WHERE: TOP-LEVEL OTHERS (SCALARREF, SCALAR, UNDEF)
-#======================================================================
+sub _render_op {
+ my ($self, undef, $v) = @_;
+ my ($op, @args) = @$v;
+ if (my $r = $self->{render_op}{$op}) {
+ return $self->$r($op, \@args);
+ }
+ { # Old SQLA compat
-sub _where_SCALARREF {
- my ($self, $where) = @_;
+ my $op = join(' ', split '_', $op);
- # literal sql
- $self->_debug("SCALAR(*top) means literal SQL: $$where");
- return ($$where);
+ my $ss = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
+ if ($ss and @args > 1) {
+ puke "Special op '${op}' requires first value to be identifier"
+ unless my ($ident) = map $_->{-ident}, grep ref($_) eq 'HASH', $args[0];
+ my $k = join(($self->{name_sep}||'.'), @$ident);
+ local our $Expand_Depth = 1;
+ return $self->${\($ss->{handler})}($k, $op, $args[1]);
+ }
+ if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
+ return $self->${\($us->{handler})}($op, $args[0]);
+ }
+ if ($ss) {
+ return $self->_render_unop_paren($op, \@args);
+ }
+ }
+ if (@args == 1) {
+ return $self->_render_unop_prefix($op, \@args);
+ } else {
+ return $self->_render_op_multop($op, \@args);
+ }
+ die "notreached";
}
-sub _where_SCALAR {
- my ($self, $where) = @_;
-
- # literal sql
- $self->_debug("NOREF(*top) means literal SQL: $where");
- return ($where);
+sub _render_op_between {
+ my ($self, $op, $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 {
+ my ($l, $h) = map [ $self->render_aqt($_) ], $low, $high;
+ (join(' ', $l->[0], $self->_sqlcase('and'), $h->[0]),
+ @{$l}[1..$#$l], @{$h}[1..$#$h])
+ }
+ };
+ my ($lhsql, @lhbind) = $self->render_aqt($left);
+ return (
+ join(' ',
+ '(', $lhsql,
+ $self->_sqlcase(join ' ', split '_', $op),
+ $rhsql, ')'
+ ),
+ @lhbind, @rhbind
+ );
}
-
-sub _where_UNDEF {
- my ($self) = @_;
- return ();
+sub _render_op_in {
+ my ($self, $op, $args) = @_;
+ my ($lhs, @rhs) = @$args;
+ my @in_bind;
+ my @in_sql = map {
+ my ($sql, @bind) = $self->render_aqt($_);
+ push @in_bind, @bind;
+ $sql;
+ } @rhs;
+ my ($lhsql, @lbind) = $self->render_aqt($lhs);
+ return (
+ $lhsql.' '.$self->_sqlcase(join ' ', split '_', $op).' ( '
+ .join(', ', @in_sql)
+ .' )',
+ @lbind, @in_bind
+ );
}
+sub _render_op_andor {
+ my ($self, $op, $args) = @_;
+ my @parts = grep length($_->[0]), map [ $self->render_aqt($_) ], @$args;
+ return '' unless @parts;
+ return @{$parts[0]} if @parts == 1;
+ my ($sql, @bind) = $self->join_clauses(' '.$self->_sqlcase($op).' ', @parts);
+ return '( '.$sql.' )', @bind;
+}
-#======================================================================
-# WHERE: BUILTIN SPECIAL OPERATORS (-in, -between)
-#======================================================================
-
-
-sub _where_field_BETWEEN {
- my ($self, $k, $op, $vals) = @_;
-
- my ($label, $and, $placeholder);
- $label = $self->_convert($self->_quote($k));
- $and = ' ' . $self->_sqlcase('and') . ' ';
- $placeholder = $self->_convert('?');
- $op = $self->_sqlcase($op);
-
- my $invalid_args = "Operator '$op' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref";
-
- my ($clause, @bind) = $self->_SWITCH_refkind($vals, {
- ARRAYREFREF => sub {
- my ($s, @b) = @$$vals;
- $self->_assert_bindval_matches_bindtype(@b);
- ($s, @b);
- },
- SCALARREF => sub {
- return $$vals;
- },
- ARRAYREF => sub {
- puke $invalid_args if @$vals != 2;
-
- my (@all_sql, @all_bind);
- foreach my $val (@$vals) {
- my ($sql, @bind) = $self->_SWITCH_refkind($val, {
- SCALAR => sub {
- return ($placeholder, $self->_bindtype($k, $val) );
- },
- SCALARREF => sub {
- return $$val;
- },
- ARRAYREFREF => sub {
- my ($sql, @bind) = @$$val;
- $self->_assert_bindval_matches_bindtype(@bind);
- return ($sql, @bind);
- },
- HASHREF => sub {
- my ($func, $arg, @rest) = %$val;
- 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);
- },
- FALLBACK => sub {
- puke $invalid_args,
- },
- });
- push @all_sql, $sql;
- push @all_bind, @bind;
- }
-
- return (
- (join $and, @all_sql),
- @all_bind
- );
- },
- FALLBACK => sub {
- puke $invalid_args,
- },
- });
-
- my $sql = "( $label $op $clause )";
- return ($sql, @bind)
-}
-
-
-sub _where_field_IN {
- my ($self, $k, $op, $vals) = @_;
-
- # backwards compatibility : if scalar, force into an arrayref
- $vals = [$vals] if defined $vals && ! ref $vals;
-
- my ($label) = $self->_convert($self->_quote($k));
- my ($placeholder) = $self->_convert('?');
- $op = $self->_sqlcase($op);
-
- my ($sql, @bind) = $self->_SWITCH_refkind($vals, {
- ARRAYREF => sub { # list of choices
- if (@$vals) { # nonempty list
- my (@all_sql, @all_bind);
-
- for my $val (@$vals) {
- my ($sql, @bind) = $self->_SWITCH_refkind($val, {
- SCALAR => sub {
- return ($placeholder, $val);
- },
- SCALARREF => sub {
- return $$val;
- },
- ARRAYREFREF => sub {
- my ($sql, @bind) = @$$val;
- $self->_assert_bindval_matches_bindtype(@bind);
- return ($sql, @bind);
- },
- HASHREF => sub {
- my ($func, $arg, @rest) = %$val;
- 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);
- },
- UNDEF => sub {
- puke(
- 'SQL::Abstract before v1.75 used to generate incorrect SQL when the '
- . "-$op 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)'
- );
- },
- });
- push @all_sql, $sql;
- push @all_bind, @bind;
- }
+sub _render_op_multop {
+ my ($self, $op, $args) = @_;
+ my @parts = grep length($_->[0]), map [ $self->render_aqt($_) ], @$args;
+ return '' unless @parts;
+ return @{$parts[0]} if @parts == 1;
+ my $join = ($op eq ','
+ ? ', '
+ : ' '.$self->_sqlcase(join ' ', split '_', $op).' '
+ );
+ return $self->join_clauses($join, @parts);
+}
- return (
- sprintf ('%s %s ( %s )',
- $label,
- $op,
- join (', ', @all_sql)
- ),
- $self->_bindtype($k, @all_bind),
- );
- }
- else { # empty list : some databases won't understand "IN ()", so DWIM
- my $sql = ($op =~ /\bnot\b/i) ? $self->{sqltrue} : $self->{sqlfalse};
- return ($sql);
- }
- },
+sub join_clauses {
+ my ($self, $join, @parts) = @_;
+ return (
+ join($join, map $_->[0], @parts),
+ (wantarray ? (map @{$_}[1..$#$_], @parts) : ()),
+ );
+}
- SCALARREF => sub { # literal SQL
- 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);
- return ("$label $op ( $sql )", @bind);
- },
+sub _render_unop_paren {
+ my ($self, $op, $v) = @_;
+ my ($sql, @bind) = $self->_render_unop_prefix($op, $v);
+ return "(${sql})", @bind;
+}
- UNDEF => sub {
- puke "Argument passed to the '$op' operator can not be undefined";
- },
+sub _render_unop_prefix {
+ my ($self, $op, $v) = @_;
+ my ($expr_sql, @bind) = $self->render_aqt($v->[0]);
- FALLBACK => sub {
- puke "special op $op requires an arrayref (or scalarref/arrayref-ref)";
- },
- });
+ my $op_sql = $self->_sqlcase($op); # join ' ', split '_', $op);
+ return ("${op_sql} ${expr_sql}", @bind);
+}
- return ($sql, @bind);
+sub _render_unop_postfix {
+ my ($self, $op, $v) = @_;
+ my ($expr_sql, @bind) = $self->render_aqt($v->[0]);
+ my $op_sql = $self->_sqlcase(join ' ', split '_', $op);
+ return ($expr_sql.' '.$op_sql, @bind);
}
# Some databases (SQLite) treat col IN (1, 2) different from
# 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;
}
# ORDER BY
#======================================================================
-sub _order_by {
+sub _expand_order_by {
my ($self, $arg) = @_;
- my (@sql, @bind);
- 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',
- $self->_sqlcase(' order by'),
- join (', ', @sql)
- )
- : ''
- ;
-
- return wantarray ? ($sql, @bind) : $sql;
+ return unless defined($arg) and not (ref($arg) eq 'ARRAY' and !@$arg);
+
+ return $self->_expand_maybe_list_expr($arg)
+ if ref($arg) eq 'HASH' and ($arg->{-op}||[''])->[0] eq ',';
+
+ my $expander = sub {
+ my ($self, $dir, $expr) = @_;
+ my @to_expand = ref($expr) eq 'ARRAY' ? @$expr : $expr;
+ foreach my $arg (@to_expand) {
+ if (
+ ref($arg) eq 'HASH'
+ and keys %$arg > 1
+ and grep /^-(asc|desc)$/, keys %$arg
+ ) {
+ puke "ordering direction hash passed to order by must have exactly one key (-asc or -desc)";
+ }
+ }
+ my @exp = map +(
+ defined($dir) ? { -op => [ $dir =~ /^-?(.*)$/ ,=> $_ ] } : $_
+ ),
+ map $self->expand_expr($_, -ident),
+ map ref($_) eq 'ARRAY' ? @$_ : $_, @to_expand;
+ return undef unless @exp;
+ return undef if @exp == 1 and not defined($exp[0]);
+ return +{ -op => [ ',', @exp ] };
+ };
+
+ local @{$self->{expand}}{qw(asc desc)} = (($expander) x 2);
+
+ return $self->$expander(undef, $arg);
}
-sub _order_by_chunks {
+sub _order_by {
my ($self, $arg) = @_;
- return $self->_SWITCH_refkind($arg, {
-
- ARRAYREF => sub {
- map { $self->_order_by_chunks ($_ ) } @$arg;
- },
-
- ARRAYREFREF => sub {
- my ($s, @b) = @$$arg;
- $self->_assert_bindval_matches_bindtype(@b);
- [ $s, @b ];
- },
+ return '' unless defined(my $expanded = $self->_expand_order_by($arg));
- SCALAR => sub {$self->_quote($arg)},
+ my ($sql, @bind) = $self->render_aqt($expanded);
- UNDEF => sub {return () },
+ return '' unless length($sql);
- SCALARREF => sub {$$arg}, # literal SQL, no quoting
+ my $final_sql = $self->_sqlcase(' order by ').$sql;
- HASHREF => sub {
- # get first pair in hash
- my ($key, $val, @rest) = %$arg;
+ return wantarray ? ($final_sql, @bind) : $final_sql;
+}
- return () unless $key;
+# _order_by no longer needs to call this so doesn't but DBIC uses it.
- if ( @rest or not $key =~ /^-(desc|asc)/i ) {
- puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
- }
+sub _order_by_chunks {
+ my ($self, $arg) = @_;
- my $direction = $1;
+ return () unless defined(my $expanded = $self->_expand_order_by($arg));
- my @ret;
- for my $c ($self->_order_by_chunks ($val)) {
- my ($sql, @bind);
+ return $self->_chunkify_order_by($expanded);
+}
- $self->_SWITCH_refkind ($c, {
- SCALAR => sub {
- $sql = $c;
- },
- ARRAYREF => sub {
- ($sql, @bind) = @$c;
- },
- });
+sub _chunkify_order_by {
+ my ($self, $expanded) = @_;
- $sql = $sql . ' ' . $self->_sqlcase($direction);
+ return grep length, $self->render_aqt($expanded)
+ if $expanded->{-ident} or @{$expanded->{-literal}||[]} == 1;
- push @ret, [ $sql, @bind];
- }
-
- return @ret;
- },
- });
+ for ($expanded) {
+ if (ref() eq 'HASH' and $_->{-op} and $_->{-op}[0] eq ',') {
+ my ($comma, @list) = @{$_->{-op}};
+ return map $self->_chunkify_order_by($_), @list;
+ }
+ return [ $self->render_aqt($_) ];
+ }
}
-
#======================================================================
# DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
#======================================================================
sub _table {
my $self = shift;
my $from = shift;
- $self->_SWITCH_refkind($from, {
- ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$from;},
- SCALAR => sub {$self->_quote($from)},
- SCALARREF => sub {$$from},
- });
+ ($self->render_aqt(
+ $self->_expand_maybe_list_expr($from, -ident)
+ ))[0];
}
# UTILITY FUNCTIONS
#======================================================================
+sub _expand_maybe_list_expr {
+ my ($self, $expr, $default) = @_;
+ return { -op => [
+ ',', map $self->expand_expr($_, $default),
+ @{$expr->{-op}}[1..$#{$expr->{-op}}]
+ ] } if ref($expr) eq 'HASH' and ($expr->{-op}||[''])->[0] eq ',';
+ return +{ -op => [ ',',
+ map $self->expand_expr($_, $default),
+ ref($expr) eq 'ARRAY' ? @$expr : $expr
+ ] };
+}
+
# highly optimized, as it's called way too often
sub _quote {
# my ($self, $label) = @_;
return '' unless defined $_[1];
return ${$_[1]} if ref($_[1]) eq 'SCALAR';
+ puke 'Identifier cannot be hashref' if ref($_[1]) eq 'HASH';
unless ($_[0]->{quote_char}) {
- $_[0]->_assert_pass_injection_guard($_[1]);
- return $_[1];
+ if (ref($_[1]) eq 'ARRAY') {
+ return join($_[0]->{name_sep}||'.', @{$_[1]});
+ } else {
+ $_[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 }
- ( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] )
+ return join(
+ $_[0]->{name_sep}||'',
+ map +(
+ $_ eq '*'
+ ? $_
+ : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r }
+ ),
+ (ref($_[1]) eq 'ARRAY'
+ ? @{$_[1]}
+ : (
+ $_[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] . ')';
+ if ($_[0]->{convert_where}) {
+ return $_[0]->_sqlcase($_[0]->{convert_where}) .'(' . $_[1] . ')';
}
return $_[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 * git: 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 * 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
-