has array_datatypes => (is => 'ro');
+has equality_op => (
+ is => 'ro',
+ default => sub { qr/^ (?: = ) $/ix },
+);
+
+has inequality_op => (
+ is => 'ro',
+ default => sub { qr/^ (?: != | <> ) $/ix },
+);
+
+has like_op => (
+ is => 'ro',
+ default => sub { qr/^ (?: is \s+ )? r?like $/xi },
+);
+
+has not_like_op => (
+ is => 'ro',
+ default => sub { qr/^ (?: is \s+ )? not \s+ r?like $/xi },
+);
+
+
sub _literal_to_dq {
my ($self, $literal) = @_;
my @bind;
my ($op, $arg, @rest) = %$v;
die 'Operator calls in update/insert must be in the form { -op => $arg }'
- if (@rest or not $op =~ /^\-(.+)/);
+ if (@rest or not $op =~ /^\-/);
}
return $self->_expr_to_dq($v);
}
return $self->_expr_to_dq($where, $logic);
}
+my %op_conversions = (
+ '==' => '=',
+ 'eq' => '=',
+ 'ne' => '!=',
+ '!' => 'NOT',
+ 'gt' => '>',
+ 'ge' => '>=',
+ 'lt' => '<',
+ 'le' => '<=',
+ 'defined' => 'IS NOT NULL',
+);
+
sub _expr_to_dq {
my ($self, $where, $logic) = @_;
) {
return $self->_literal_to_dq($$where);
} elsif (ref($where) eq 'REF' and ref($$where) eq 'HASH') {
- return $$where;
+ return map_dq_tree {
+ if (
+ is_Operator
+ and not $_->{operator}{'SQL.Naive'}
+ and my $op = $_->{operator}{'Perl'}
+ ) {
+ my $sql_op = $op_conversions{$op} || uc($op);
+ return +{
+ %{$_},
+ operator => { 'SQL.Naive' => $sql_op }
+ };
+ }
+ return $_;
+ } $$where;
} elsif (!ref($where) or Scalar::Util::blessed($where)) {
return $self->_value_to_dq($where);
}
}
my ($op, $value) = %$v;
s/^-//, s/_/ /g for $op;
- if ($op =~ /^(and|or)$/i) {
+ if ($op =~ /^(?:and|or)$/i) {
return $self->_expr_to_dq({ $k => $value }, $op);
} elsif (
my $special_op = List::Util::first {$op =~ $_->{regex}}
) {
return $self->_literal_to_dq(
[ $special_op->{handler}->($k, $op, $value) ]
- );;
+ );
} elsif ($op =~ /^(?:AND|OR|NEST)_?\d+$/i) {
die "Use of [and|or|nest]_N modifiers is no longer supported";
}
}
};
if ($op eq 'BETWEEN' or $op eq 'IN' or $op eq 'NOT IN' or $op eq 'NOT BETWEEN') {
+ die "Argument passed to the '$op' operator can not be undefined" unless defined $rhs;
+ $rhs = [$rhs] unless ref $rhs;
if (ref($rhs) ne 'ARRAY') {
- if ($op =~ /IN$/) {
+ if ($op =~ /^(?:NOT )?IN$/) {
# have to add parens if none present because -in => \"SELECT ..."
# got documented. mst hates everything.
if (ref($rhs) eq 'SCALAR') {
my $x = $$rhs;
1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
$rhs = \$x;
- } else {
- my ($x, @rest) = @{$$rhs};
- 1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
- $rhs = \[ $x, @rest ];
+ } elsif (ref($rhs) eq 'REF') {
+ if (ref($$rhs) eq 'ARRAY') {
+ my ($x, @rest) = @{$$rhs};
+ 1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
+ $rhs = \[ $x, @rest ];
+ } elsif (ref($$rhs) eq 'HASH') {
+ return $self->_op_to_dq($op, $self->_ident_to_dq($k), $$rhs);
+ }
}
}
return $self->_op_to_dq(
$op, $self->_ident_to_dq($k), $self->_literal_to_dq($$rhs)
);
}
- return $self->_literal_to_dq($self->{sqlfalse}) unless @$rhs;
+ die "Operator '$op' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref"
+ if $op =~ /^(?:NOT )?BETWEEN$/ and (@$rhs != 2 or grep !defined, @$rhs);
+ if (grep !defined, @$rhs) {
+ my ($inop, $logic, $nullop) = $op =~ /^NOT/
+ ? (-not_in => AND => { '!=' => undef })
+ : (-in => OR => undef);
+ if (my @defined = grep defined, @$rhs) {
+ return $self->_expr_to_dq_ARRAYREF([
+ { $k => { $inop => \@defined } },
+ { $k => $nullop },
+ ], $logic);
+ }
+ return $self->_expr_to_dq_HASHREF({ $k => $nullop });
+ }
+ return $self->_literal_to_dq(
+ $op =~ /^NOT/ ? $self->{sqltrue} : $self->{sqlfalse}
+ ) unless @$rhs;
return $self->_op_to_dq(
$op, $self->_ident_to_dq($k), map $self->_expr_to_dq($_), @$rhs
)
- } elsif ($op =~ s/^NOT (?!LIKE)//) {
+ } elsif ($op =~ s/^NOT (?!R?LIKE)//) {
return $self->_where_hashpair_to_dq(-not => { $k => { $op => $rhs } });
} elsif ($op eq 'IDENT') {
return $self->_op_to_dq(
);
} elsif (!defined($rhs)) {
my $null_op = do {
- if ($op eq '=' or $op eq 'LIKE') {
+ warn "Supplying an undefined argument to '$op' is deprecated"
+ if $op =~ $self->like_op or $op =~ $self->not_like_op;
+ if ($op =~ $self->equality_op or $op =~ $self->like_op or $op eq 'IS') {
'IS NULL'
- } elsif ($op eq '!=') {
+ } elsif ($op =~ $self->inequality_op or $op =~ $self->not_like_op or $op eq 'IS NOT') {
'IS NOT NULL'
} else {
die "Can't do undef -> NULL transform for operator ${op}";
}
if (ref($rhs) eq 'ARRAY') {
if (!@$rhs) {
+ if ($op =~ $self->like_op or $op =~ $self->not_like_op) {
+ warn "Supplying an empty arrayref to '$op' is deprecated";
+ } elsif ($op !~ $self->equality_op and $op !~ $self->inequality_op) {
+ die "operator '$op' applied on an empty array (field '$k')";
+ }
return $self->_literal_to_dq(
- $op eq '!=' ? $self->{sqltrue} : $self->{sqlfalse}
+ ($op =~ $self->inequality_op or $op =~ $self->not_like_op)
+ ? $self->{sqltrue} : $self->{sqlfalse}
);
} elsif (defined($rhs->[0]) and $rhs->[0] =~ /^-(and|or)$/i) {
return $self->_expr_to_dq_ARRAYREF([
], uc($1));
} elsif ($op =~ /^-(?:AND|OR|NEST)_?\d+/) {
die "Use of [and|or|nest]_N modifiers is no longer supported";
+ } elsif (@$rhs > 1 and ($op =~ $self->inequality_op or $op =~ $self->not_like_op)) {
+ warn "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)";
}
return $self->_expr_to_dq_ARRAYREF([
map +{ $k => { $op => $_ } }, @$rhs
my $dq = Order(
undef,
(defined($dir) ? (!!($dir =~ /desc/i)) : undef),
- (defined($nulls) ? ($nulls =~ /first/i ? 1 : -1) : undef),
+ $nulls,
($from ? ($from) : undef),
);
$dq->{by} = $$arg;
} elsif (ref($arg) eq 'SCALAR') {
- # < mst> right, but if it doesn't match that, it goes "ok, right, not sure,
+ # < mst> right, but if it doesn't match that, it goes "ok, right, not sure,
# totally leaving this untouched as a literal"
# < mst> so I -think- it's relatively robust
# < ribasushi> right, it's relatively safe then
# < ribasushi> is this regex centralized?
# < mst> it only exists in _order_by_to_dq in SQL::Abstract::Converter
- # < mst> it only exists because you were kind enough to support new
+ # < mst> it only exists because you were kind enough to support new
# dbihacks crack combined with old literal order_by crack
# < ribasushi> heh :)
$val = $arg->{$key};
} elsif ($key =~ /^-nulls$/i) {
$nulls = $arg->{$key};
- die "invalid value for -nulls" unless $nulls =~ /^(?:first|last)$/i;
+ die "invalid value for -nulls" unless $nulls =~ /^(?:first|last|none)$/i;
} else {
- die "invalid key in hash passed to _order_by_to_dq";
+ die "invalid key ${key} in hash passed to _order_by_to_dq";
}
}
projects / dbsrgits/SQL-Abstract.git / blobdiff