use Carp ();
use List::Util ();
use Scalar::Util ();
-use Data::Query::Constants qw(
- DQ_IDENTIFIER DQ_OPERATOR DQ_VALUE DQ_LITERAL DQ_JOIN DQ_SELECT DQ_ORDER
- DQ_WHERE DQ_DELETE DQ_UPDATE DQ_INSERT
-);
-use Data::Query::ExprHelpers qw(perl_scalar_value);
+use Data::Query::ExprHelpers;
use Moo;
use namespace::clean;
);
has lower_case => (
- is => 'ro'
+ is => 'ro'
);
has default_logic => (
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;
($literal, @bind) = @$literal if ref($literal) eq 'ARRAY';
- +{
- type => DQ_LITERAL,
- subtype => 'SQL',
- literal => $literal,
- (@bind ? (values => [ $self->_bind_to_dq(@bind) ]) : ()),
- };
+ Literal('SQL', $literal, [ $self->_bind_to_dq(@bind) ]);
}
sub _bind_to_dq {
my ($self, $ident) = @_;
$self->_assert_pass_injection_guard($ident)
unless $self->renderer_will_quote;
- $self->_maybe_convert_dq({
- type => DQ_IDENTIFIER,
- elements => [ split /\Q${\$self->identifier_sep}/, $ident ],
- });
+ $self->_maybe_convert_dq(
+ Identifier(do {
+ if (my $sep = $self->identifier_sep) {
+ split /\Q$sep/, $ident
+ } else {
+ $ident
+ }
+ })
+ );
}
sub _maybe_convert_dq {
my ($self, $dq) = @_;
if (my $c = $self->{where_convert}) {
- +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => 'apply' },
- args => [
- { type => DQ_IDENTIFIER, elements => [ $self->_sqlcase($c) ] },
- $dq
- ]
- };
+ Operator({ 'SQL.Naive' => 'apply' }, [
+ Identifier($self->_sqlcase($c)),
+ $dq
+ ]
+ );
} else {
$dq;
}
sub _op_to_dq {
my ($self, $op, @args) = @_;
$self->_assert_pass_injection_guard($op);
- +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => $op },
- args => \@args
- };
+ Operator({ 'SQL.Naive' => $op }, \@args);
}
sub _assert_pass_injection_guard {
(ref($r_source) eq 'ARRAY' ? @$r_source : $r_source),
];
}
- +{
- type => DQ_INSERT,
- target => $self->_table_to_dq($table),
- (@names ? (names => [ map $self->_ident_to_dq($_), @names ]) : ()),
- values => [ \@values ],
- ($returning ? (returning => $returning) : ()),
- };
+ Insert(
+ (@names ? ([ map $self->_ident_to_dq($_), @names ]) : undef),
+ [ \@values ],
+ $self->_table_to_dq($table),
+ ($returning ? ($returning) : undef),
+ );
}
sub _mutation_rhs_to_dq {
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);
}
push @set, [ $self->_ident_to_dq($k), $self->_mutation_rhs_to_dq($v) ];
}
- return +{
- type => DQ_UPDATE,
- target => $self->_table_to_dq($table),
- set => \@set,
- where => $self->_where_to_dq($where),
- };
+ Update(
+ \@set,
+ $self->_where_to_dq($where),
+ $self->_table_to_dq($table),
+ );
}
sub _source_to_dq {
my $source_dq = $self->_table_to_dq($table);
if (my $where_dq = $self->_where_to_dq($where)) {
- $source_dq = {
- type => DQ_WHERE,
- from => $source_dq,
- where => $where_dq,
- };
+ $source_dq = Where($where_dq, $source_dq);
}
$source_dq;
my $ordered_dq = do {
if ($order) {
- $self->_order_by_to_dq($order, undef, $source_dq);
+ $self->_order_by_to_dq($order, undef, undef, $source_dq);
} else {
$source_dq
}
$fields ||= '*';
- return +{
- type => DQ_SELECT,
- select => $self->_select_field_list_to_dq($fields),
- from => $from_dq,
- };
+ Select(
+ $self->_select_field_list_to_dq($fields),
+ $from_dq,
+ );
}
sub _select_field_list_to_dq {
sub _delete_to_dq {
my ($self, $table, $where) = @_;
- +{
- type => DQ_DELETE,
- target => $self->_table_to_dq($table),
- where => $self->_where_to_dq($where),
- }
+ Delete(
+ $self->_where_to_dq($where),
+ $self->_table_to_dq($table),
+ );
}
sub _where_to_dq {
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);
}
foreach my $arg (@args) {
if (
- $arg->{type} eq DQ_OPERATOR and $arg->{operator}{'SQL.Naive'} eq 'apply'
- and @{$arg->{args}} == 2 and $arg->{args}[1]{type} ne DQ_OPERATOR
+ is_Operator($arg) and $arg->{operator}{'SQL.Naive'} eq 'apply'
+ and @{$arg->{args}} == 2 and !is_Operator($arg->{args}[1])
+
) {
$arg->{operator}{'SQL.Naive'} = (shift @{$arg->{args}})->{elements}->[0];
}
map +{ $k => $_ }, @$v
], $logic);
} elsif (ref($v) eq 'SCALAR' or (ref($v) eq 'REF' and ref($$v) eq 'ARRAY')) {
- return +{
- type => DQ_LITERAL,
- subtype => 'SQL',
- parts => [ $self->_ident_to_dq($k), $self->_literal_to_dq($$v) ]
- };
+ return Literal('SQL', [ $self->_ident_to_dq($k), $self->_literal_to_dq($$v) ]);
}
my ($op, $rhs) = do {
if (ref($v) eq 'HASH') {
}
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
}
sub _order_by_to_dq {
- my ($self, $arg, $dir, $from) = @_;
+ my ($self, $arg, $dir, $nulls, $from) = @_;
return unless $arg;
- my $dq = {
- type => DQ_ORDER,
- (defined($dir) ? (reverse => !!($dir =~ /desc/i)) : ()),
- ($from ? (from => $from) : ()),
- };
+ my $dq = Order(
+ undef,
+ (defined($dir) ? (!!($dir =~ /desc/i)) : undef),
+ $nulls,
+ ($from ? ($from) : undef),
+ );
if (!ref($arg)) {
$dq->{by} = $self->_ident_to_dq($arg);
my ($outer, $inner);
foreach my $member (@$arg) {
local $Order_Inner;
- my $next = $self->_order_by_to_dq($member, $dir, $from);
+ my $next = $self->_order_by_to_dq($member, $dir, $nulls, $from);
$outer ||= $next;
$inner->{from} = $next if $inner;
$inner = $Order_Inner || $next;
return $outer;
} elsif (ref($arg) eq 'REF' and ref($$arg) eq 'ARRAY') {
$dq->{by} = $self->_literal_to_dq($$arg);
+ } elsif (ref($arg) eq 'REF' and ref($$arg) eq 'HASH') {
+ $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 :)
- if (my ($ident, $dir) = $$arg =~ /^(\w+)(?:\s+(desc|asc))?$/i) {
+ # this should take into account our quote char and name sep
+
+ my $match_ident = '\w+(?:\.\w+)*';
+
+ if (my ($ident, $dir) = $$arg =~ /^(${match_ident})(?:\s+(desc|asc))?$/i) {
$dq->{by} = $self->_ident_to_dq($ident);
$dq->{reverse} = 1 if $dir and lc($dir) eq 'desc';
} else {
$dq->{by} = $self->_literal_to_dq($$arg);
}
} elsif (ref($arg) eq 'HASH') {
- my ($key, $val, @rest) = %$arg;
+ return () unless %$arg;
+
+ my ($direction, $val);
+ foreach my $key (keys %$arg) {
+ if ( $key =~ /^-(desc|asc)/i ) {
+ die "hash passed to _order_by_to_dq must have exactly one of -desc or -asc"
+ if defined $direction;
+ $direction = $1;
+ $val = $arg->{$key};
+ } elsif ($key =~ /^-nulls$/i) {
+ $nulls = $arg->{$key};
+ die "invalid value for -nulls" unless $nulls =~ /^(?:first|last|none)$/i;
+ } else {
+ die "invalid key ${key} in hash passed to _order_by_to_dq";
+ }
+ }
- return unless $key;
+ die "hash passed to _order_by_to_dq must have exactly one of -desc or -asc"
+ unless defined $direction;
- if (@rest or not $key =~ /^-(desc|asc)/i) {
- die "hash passed to _order_by must have exactly one key (-desc or -asc)";
- }
- my $dir = uc $1;
- return $self->_order_by_to_dq($val, $dir, $from);
+ return $self->_order_by_to_dq($val, $direction, $nulls, $from);
} else {
die "Can't handle $arg in _order_by_to_dq";
}
die "Empty FROM list" unless my @f = @$from;
my $dq = $self->_table_to_dq(shift @f);
while (my $x = shift @f) {
- $dq = {
- type => DQ_JOIN,
- left => $dq,
- right => $self->_table_to_dq($x),
- };
+ $dq = Join(
+ $dq,
+ $self->_table_to_dq($x),
+ );
}
$dq;
} elsif (ref($from) eq 'SCALAR' or (ref($from) eq 'REF')) {
projects / dbsrgits/SQL-Abstract.git / blobdiff