From: Vincent Pit Date: Sat, 9 Jan 2010 14:56:42 +0000 (+0100) Subject: Test keys/values @array X-Git-Tag: v0.04~4 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=c79d4e423275faf328a1cdb9e47fdd1ba432388d;p=perl%2Fmodules%2Fautovivification.git Test keys/values @array --- diff --git a/MANIFEST b/MANIFEST index bf44d3a..21c20c2 100644 --- a/MANIFEST +++ b/MANIFEST @@ -12,6 +12,7 @@ t/20-hash.t t/22-hash-kv.t t/30-array.t t/31-array-fast.t +t/32-array-kv.t t/40-scope.t t/41-padsv.t t/91-pod.t diff --git a/lib/autovivification.pm b/lib/autovivification.pm index bff3f85..1bab02f 100644 --- a/lib/autovivification.pm +++ b/lib/autovivification.pm @@ -65,6 +65,7 @@ Enables the features given in C<@opts>, which can be : C<'fetch'> Turn off autovivification for rvalue dereferencing expressions, such as C<< $value = $hashref->{key}[$idx]{$field} >>, C<< keys %{$hashref->{key}} >> or C<< values %{$hashref->{key}} >>. +Starting from perl C<5.11>, it also covers C and C on array references. When the expression would have autovivified, C is returned for a plain fetch, while C and C return C<0> in scalar context and the empty list in list context. =item * diff --git a/samples/hash2array.pl b/samples/hash2array.pl index e70b69b..9fc4a61 100644 --- a/samples/hash2array.pl +++ b/samples/hash2array.pl @@ -3,7 +3,7 @@ use strict; use warnings; -use Fatal qw/open/; +use Fatal qw/open close/; use Text::Balanced qw/extract_bracketed/; open my $hash_t, '<', 't/20-hash.t'; @@ -27,13 +27,48 @@ sub hash2array { sub dump_array { my ($a) = @_; + return 'undef' unless defined $a; - return $a unless ref $a; - die "Invalid argument" unless ref $a eq 'ARRAY'; - return '[ ' . join(', ', map dump_array($_), @$a) . ' ]'; + + if (ref $a) { + die "Invalid argument" unless ref $a eq 'ARRAY'; + return '[ ' . join(', ', map dump_array($_), @$a) . ' ]'; + } else { + $a = "'\Q$a\E'" if $a !~ /^\s*\d/; + return $a; + } +} + +sub extract ($$) { + extract_bracketed $_[0], $_[1], qr/.*?(?) { @@ -46,26 +81,31 @@ while (<$hash_t>) { print $array_t $_; print $array_fast_t $_; } else { - for my $file ([ 1, $array_t ], [ 0, $array_fast_t ]) { - local $_ = $_; - s!(\ba\b)?(\s*)HASH\b!($1 ? 'an': '') . "$2ARRAY"!eg; - s{ - {\s*(['"]?[a-z]['"]?(?:\s*,\s*['"]?[a-z]['"]?)*)\s*} - }{ - '[' . join(', ', map { my $n = num($_); $file->[0] ? "\$N[$n]" : $n } - split /\s*,\s*/, $1) . ']' - }gex; - s!%(\{?)\$!\@$1\$!g; - my $buf; - my $suffix = $_; - my ($bracket, $prefix); - while (do { ($bracket, $suffix, $prefix) = extract($suffix); $bracket }) { - $buf .= $prefix . dump_array(hash2array(eval $bracket)); - } - $buf .= $suffix; - $buf =~ s/\s+/ /g; - $buf =~ s/\s+$//; - print { $file->[1] } "$buf\n"; + print $array_t convert_testcase($_, 0); + print $array_fast_t convert_testcase($_, 1); + } +} + +close $hash_t; +close $array_t; +close $array_fast_t; + +open my $hash_specific_t, '<', 't/22-hash-kv.t'; +open my $array_specific_t, '>', 't/32-array-kv.t'; + +$in_data = 0; +while (<$hash_specific_t>) { + if (/^__DATA__$/) { + $in_data = 1; + } elsif (!$in_data) { + s{'%'}{'\@'}; + if (/\bplan\s*[\s\(]\s*tests\b/) { + s/\s*;?\s*$//; + s/^(\s*)//; + $_ = "$1if (\$] >= 5.011) { $_ } else { plan skip_all => 'perl 5.11 required for keys/values \@array' }\n"; } + } else { + $_ = convert_testcase($_, 1); } + print $array_specific_t $_; } diff --git a/t/22-hash-kv.t b/t/22-hash-kv.t index a965ed2..999bfdf 100644 --- a/t/22-hash-kv.t +++ b/t/22-hash-kv.t @@ -3,7 +3,11 @@ use strict; use warnings; -use Test::More tests => 9 * 3 * 64; +use Test::More; + +BEGIN { + plan tests => 9 * 3 * 64; +} use lib 't/lib'; use autovivification::TestCases; @@ -35,10 +39,10 @@ $x # [ keys %$x ] # '', [ ], undef # $x # [ keys %$x ] # '', [ ], undef # +fetch $x # [ keys %$x ] # '', [ ], { } # +exists +delete +store -$x->{a} ='b' # [ keys %$x ] # '', [ 'a' ], { a => 'b' } -$x->{a} ='b' # [ keys %$x ] # '', [ 'a' ], { a => 'b' } # -$x->{a} ='b' # [ keys %$x ] # '', [ 'a' ], { a => 'b' } # +fetch -$x->{a} ='b' # [ keys %$x ] # '', [ 'a' ], { a => 'b' } # +exists +delete +store +$x->{a} = 1 # [ keys %$x ] # '', [ 'a' ], { a => 1 } +$x->{a} = 1 # [ keys %$x ] # '', [ 'a' ], { a => 1 } # +$x->{a} = 1 # [ keys %$x ] # '', [ 'a' ], { a => 1 } # +fetch +$x->{a} = 1 # [ keys %$x ] # '', [ 'a' ], { a => 1 } # +exists +delete +store $x # keys %{$x->{a}} # '', 0, { a => { } } $x # keys %{$x->{a}} # '', 0, undef # @@ -76,10 +80,10 @@ $x # [ values %$x ] # '', [ ], undef # $x # [ values %$x ] # '', [ ], undef # +fetch $x # [ values %$x ] # '', [ ], { } # +exists +delete +store -$x->{a} ='b' # [ values %$x ] # '', [ 'b' ], { a=>'b' } -$x->{a} ='b' # [ values %$x ] # '', [ 'b' ], { a=>'b' } # -$x->{a} ='b' # [ values %$x ] # '', [ 'b' ], { a=>'b' } # +fetch -$x->{a} ='b' # [ values %$x ] # '', [ 'b' ], { a=>'b' } # +exists +delete +store +$x->{a} = 1 # [ values %$x ] # '', [ 1 ], { a => 1 } +$x->{a} = 1 # [ values %$x ] # '', [ 1 ], { a => 1 } # +$x->{a} = 1 # [ values %$x ] # '', [ 1 ], { a => 1 } # +fetch +$x->{a} = 1 # [ values %$x ] # '', [ 1 ], { a => 1 } # +exists +delete +store $x # values %{$x->{a}} # '', 0, { a => { } } $x # values %{$x->{a}} # '', 0, undef # diff --git a/t/32-array-kv.t b/t/32-array-kv.t new file mode 100644 index 0000000..9ca1f05 --- /dev/null +++ b/t/32-array-kv.t @@ -0,0 +1,103 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +BEGIN { + if ($] >= 5.011) { plan tests => 9 * 3 * 64 } else { plan skip_all => 'perl 5.11 required for keys/values @array' } +} + +use lib 't/lib'; +use autovivification::TestCases; + +while () { + 1 while chomp; + next unless /#/; + testcase_ok($_, '@'); +} + +__DATA__ + +--- keys --- + +$x # keys @$x # '', 0, [ ] +$x # keys @$x # '', 0, undef # +$x # keys @$x # '', 0, undef # +fetch +$x # keys @$x # '', 0, [ ] # +exists +$x # keys @$x # '', 0, [ ] # +delete +$x # keys @$x # '', 0, [ ] # +store + +$x # keys @$x # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch +$x # keys @$x # '', 0, [ ] # +strict +exists +$x # keys @$x # '', 0, [ ] # +strict +delete +$x # keys @$x # '', 0, [ ] # +strict +store + +$x # [ keys @$x ] # '', [ ], [ ] +$x # [ keys @$x ] # '', [ ], undef # +$x # [ keys @$x ] # '', [ ], undef # +fetch +$x # [ keys @$x ] # '', [ ], [ ] # +exists +delete +store + +$x->[0] = 1 # [ keys @$x ] # '', [0], [ 1 ] +$x->[0] = 1 # [ keys @$x ] # '', [0], [ 1 ] # +$x->[0] = 1 # [ keys @$x ] # '', [0], [ 1 ] # +fetch +$x->[0] = 1 # [ keys @$x ] # '', [0], [ 1 ] # +exists +delete +store + +$x # keys @{$x->[0]} # '', 0, [ [ ] ] +$x # keys @{$x->[0]} # '', 0, undef # +$x # keys @{$x->[0]} # '', 0, undef # +fetch +$x # keys @{$x->[0]} # '', 0, [ [ ] ] # +exists +$x # keys @{$x->[0]} # '', 0, [ [ ] ] # +delete +$x # keys @{$x->[0]} # '', 0, [ [ ] ] # +store + +$x # keys @{$x->[0]} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch +$x # keys @{$x->[0]} # '', 0, [ [ ] ] # +strict +exists +$x # keys @{$x->[0]} # '', 0, [ [ ] ] # +strict +delete +$x # keys @{$x->[0]} # '', 0, [ [ ] ] # +strict +store + +$x # [ keys @{$x->[0]} ] # '', [ ], [ [ ] ] +$x # [ keys @{$x->[0]} ] # '', [ ], undef # +$x # [ keys @{$x->[0]} ] # '', [ ], undef # +fetch +$x # [ keys @{$x->[0]} ] # '', [ ], [ [ ] ] # +exists +delete +store + +--- values --- + +$x # values @$x # '', 0, [ ] +$x # values @$x # '', 0, undef # +$x # values @$x # '', 0, undef # +fetch +$x # values @$x # '', 0, [ ] # +exists +$x # values @$x # '', 0, [ ] # +delete +$x # values @$x # '', 0, [ ] # +store + +$x # values @$x # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch +$x # values @$x # '', 0, [ ] # +strict +exists +$x # values @$x # '', 0, [ ] # +strict +delete +$x # values @$x # '', 0, [ ] # +strict +store + +$x # [ values @$x ] # '', [ ], [ ] +$x # [ values @$x ] # '', [ ], undef # +$x # [ values @$x ] # '', [ ], undef # +fetch +$x # [ values @$x ] # '', [ ], [ ] # +exists +delete +store + +$x->[0] = 1 # [ values @$x ] # '', [ 1 ], [ 1 ] +$x->[0] = 1 # [ values @$x ] # '', [ 1 ], [ 1 ] # +$x->[0] = 1 # [ values @$x ] # '', [ 1 ], [ 1 ] # +fetch +$x->[0] = 1 # [ values @$x ] # '', [ 1 ], [ 1 ] # +exists +delete +store + +$x # values @{$x->[0]} # '', 0, [ [ ] ] +$x # values @{$x->[0]} # '', 0, undef # +$x # values @{$x->[0]} # '', 0, undef # +fetch +$x # values @{$x->[0]} # '', 0, [ [ ] ] # +exists +$x # values @{$x->[0]} # '', 0, [ [ ] ] # +delete +$x # values @{$x->[0]} # '', 0, [ [ ] ] # +store + +$x # values @{$x->[0]} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch +$x # values @{$x->[0]} # '', 0, [ [ ] ] # +strict +exists +$x # values @{$x->[0]} # '', 0, [ [ ] ] # +strict +delete +$x # values @{$x->[0]} # '', 0, [ [ ] ] # +strict +store + +$x # [ values @{$x->[0]} ] # '', [ ], [ [ ] ] +$x # [ values @{$x->[0]} ] # '', [ ], undef # +$x # [ values @{$x->[0]} ] # '', [ ], undef # +fetch +$x # [ values @{$x->[0]} ] # '', [ ], [ [ ] ] # +exists +delete +store