From: Matt S Trout Date: Mon, 18 Mar 2019 17:04:43 +0000 (+0000) Subject: extract and/or expansion X-Git-Tag: v1.90_01~364 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=70f98e4bba2ff14a3750ef75a9cb1ea575df6acb;p=dbsrgits%2FSQL-Abstract.git extract and/or expansion --- diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index 16cadc0..dfd317c 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -196,6 +196,8 @@ sub new { -value => '_expand_value', -not => '_expand_not', -bool => '_expand_bool', + -and => '_expand_andor', + -or => '_expand_andor', }; return bless \%opt, $class; @@ -539,13 +541,13 @@ sub _expand_expr { return undef unless my $kc = keys %$expr; if ($kc > 1) { $logic ||= 'and'; - return +{ -op => [ - $logic, - map $self->_expand_expr({ $_ => $expr->{$_} }, $logic), - sort keys %$expr - ] }; + return $self->_expand_andor("-${logic}", $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 ... ]"; + } if (my $exp = $self->{expand}{$key}) { return $self->$exp($key, $value); } @@ -553,37 +555,7 @@ sub _expand_expr { } if (ref($expr) eq 'ARRAY') { my $logic = lc($logic || $self->{logic}); - $logic eq 'and' or $logic eq 'or' or puke "unknown logic: $logic"; - - my @expr = grep { - (ref($_) eq 'ARRAY' and @$_) - or (ref($_) eq 'HASH' and %$_) - or 1 - } @$expr; - - my @res; - - while (my ($el) = splice @expr, 0, 1) { - puke "Supplying an empty left hand side argument is not supported in array-pairs" - unless defined($el) and length($el); - my $elref = ref($el); - if (!$elref) { - local $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 $Expand_Depth = 0; - push @res, grep defined, $self->_expand_expr($el) if %$el; - } else { - die "notreached"; - } - } - # ??? - # return $res[0] if @res == 1; - return { -op => [ $logic, @res ] }; + return $self->_expand_andor("-${logic}", $expr); } if (my $literal = is_literal_value($expr)) { return +{ -literal => $literal }; @@ -611,10 +583,6 @@ sub _expand_expr_hashpair { } if ($k =~ /^-/) { $self->_assert_pass_injection_guard($k =~ /^-(.*)$/s); - if ($k =~ s/ [_\s]? \d+ $//x ) { - belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. ' - . "You probably wanted ...-and => [ $k => COND1, $k => COND2 ... ]"; - } if ($k eq '-nest') { # DBIx::Class requires a nest warning to be emitted once but the private # method it overrode to do so no longer exists @@ -635,15 +603,6 @@ sub _expand_expr_hashpair { $self->_expand_expr({ "-${rest}", $v }, $logic) ] }; } - if (my ($logic) = $k =~ /^-(and|or)$/i) { - if (ref($v) eq 'HASH') { - return $self->_expand_expr($v, $logic); - } - if (ref($v) eq 'ARRAY') { - return $self->_expand_expr($v, $logic); - } - die "notreached"; - } { my $op = $k; $op =~ s/^-// if length($op) > 1; @@ -871,15 +830,14 @@ sub _expand_expr_hashpair { if (ref($v) eq 'ARRAY') { return $self->sqlfalse unless @$v; $self->_debug("ARRAY($k) means distribute over elements"); - my $this_logic = ( - $v->[0] =~ /^-((?:and|or))$/i - ? ($v = [ @{$v}[1..$#$v] ], $1) - : ($self->{logic} || 'or') + my $this_logic = lc( + $v->[0] =~ /^-(and|or)$/i + ? shift(@{$v = [ @$v ]}) + : '-'.($self->{logic} || 'or') ); - return +{ -op => [ - $this_logic, - map $self->_expand_expr({ $k => $_ }, $this_logic), @$v - ] }; + return $self->_expand_expr({ + $this_logic => [ map +{ $k => $_ }, @$v ] + }); } if (my $literal = is_literal_value($v)) { unless (length $k) { @@ -925,6 +883,52 @@ sub _expand_bool { return $self->_expand_ident(-ident => $v); } +sub _expand_andor { + my ($self, $k, $v) = @_; + my ($logic) = $k =~ /^-(.*)$/; + if (ref($v) eq 'HASH') { + return +{ -op => [ + $logic, + map $self->_expand_expr({ $_ => $v->{$_} }, $logic), + sort keys %$v + ] }; + } + if (ref($v) eq 'ARRAY') { + $logic eq 'and' or $logic eq 'or' or puke "unknown logic: $logic"; + + 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"; + } + } + # ??? + # return $res[0] if @res == 1; + return { -op => [ $logic, @res ] }; + } + die "notreached"; +} + sub _recurse_where { my ($self, $where, $logic) = @_; diff --git a/t/04modifiers.t b/t/04modifiers.t index a271b32..9a1dfb1 100644 --- a/t/04modifiers.t +++ b/t/04modifiers.t @@ -428,7 +428,7 @@ for my $case (@numbered_mods) { local $SIG{__WARN__} = sub { push @w, @_ }; my $sql = SQL::Abstract->new($case->{args} || {}); - { + lives_ok { my ($old_s, @old_b) = $sql->where($case->{backcompat}); my ($new_s, @new_b) = $sql->where($case->{correct}); is_same_sql_bind(