use strict;
use warnings;
-use Test::More tests => (2 * 24 + 7) + (2 * 5 + 5) + 1;
+use Test::More tests => (2 * 27 + 9) + 2 * (2 * 5 + 5) + 1;
-use Variable::Magic qw<cast dispell VMG_UVAR>;
+use Variable::Magic qw<
+ cast dispell
+ VMG_UVAR
+ VMG_COMPAT_HASH_DELETE_NOUVAR_VOID
+>;
use lib 't/lib';
use Variable::Magic::TestWatcher;
ok $s, "hash: exists correctly ($_)";
}
+# delete
+
+watch { delete $h{bar} } +{
+ ((delete => 1) x !VMG_COMPAT_HASH_DELETE_NOUVAR_VOID, copy => 1) x VMG_UVAR
+}, 'delete in void context';
+
+for (1 .. 2) {
+ $s = watch { delete $h{baz} } +{ (delete => 1, copy => 1) x VMG_UVAR },
+ "delete in scalar context ($_)";
+ my $exp = $_ == 1 ? $n{baz} : undef;
+ is $s, $exp, "hash: delete correctly ($_)";
+}
+
+# clear
+
watch { %h = () } { clear => 1 }, 'empty in list context';
watch { $h{a} = -1; %h = (b => $h{a}) }
$SKIP = 'uvar magic';
} else {
local $@;
- unless (eval { require B::Deparse; 1 }) {
- $SKIP = 'B::Deparse';
+ unless (eval { require B; require B::Deparse; 1 }) {
+ $SKIP = 'B and B::Deparse';
}
}
if ($SKIP) {
$SKIP .= ' required to test uvar/clear interaction fix';
- skip $SKIP => 2 * 5 + 5;
+ skip $SKIP => 2 * ( 2 * 5 + 5);
}
my $bd = B::Deparse->new;
- my %h = (a => 13, b => 15);
- watch { cast %h, $wiz } { }, 'cast clear/uvar';
+ my %h1 = (a => 13, b => 15);
+ my %h2 = (a => 17, b => 19);
+
+ my @tests = (
+ [ \%h1 => 'first hash' => (14, 16) ],
+ [ \%h2 => 'second hash' => (18, 20) ],
+ );
+
+ for my $test (@tests) {
+ my ($h, $desc, @exp) = @$test;
- my $code = sub { my $x = $h{$_[0]}; ++$x; $x };
- my $before = $bd->coderef2text($code);
- my $res;
+ watch { &cast($h, $wiz) } { }, "cast clear/uvar on $desc";
- watch { $res = $code->('a') } { fetch => 1 }, 'fixed fetch "a"';
- is $res, 14, 'uvar: fixed fetch "a" returned the right thing';
+ my $code = sub { my $x = $h->{$_[0]}; ++$x; $x };
+ my $before = $bd->coderef2text($code);
+ my $res;
- my $after = $bd->coderef2text($code);
- is $before, $after, 'uvar: fixed fetch deparse correctly';
+ watch { $res = $code->('a') } { fetch => 1 }, "fetch constant 'a' from $desc";
+ is $res, $exp[0], "uvar: fetch constant 'a' from $desc was correct";
- watch { $res = $code->('b') } { fetch => 1 }, 'fixed fetch "b"';
- is $res, 16, 'uvar: fixed fetch "b" returned the right thing';
+ my $after = $bd->coderef2text($code);
+ is $before, $after,
+ "uvar: code deparses correctly after constant fetch from $desc";
- $after = $bd->coderef2text($code);
- is $before, $after, 'uvar: fixed fetch deparse correctly';
+ my $key = 'b';
+ watch { $res = $code->($key) } { fetch => 1 },"fetch variable 'b' from $desc";
+ is $res, $exp[1], "uvar: fetch variable 'b' from $desc was correct";
- watch { %h = () } { clear => 1 }, 'fixed clear';
+ $after = $bd->coderef2text($code);
+ is $before, $after,
+ "uvar: code deparses correctly after variable fetch from $desc";
- watch { dispell %h, $wiz } { }, 'dispell clear/uvar';
+ watch { %$h = () } { clear => 1 }, "fixed clear for $desc";
- require B;
- ok(!(B::svref_2object(\%h)->FLAGS & B::SVs_RMG()), '%h no longer has the RMG flag set');
+ watch { &dispell($h, $wiz) } { }, "dispell clear/uvar from $desc";
+
+ ok(!(B::svref_2object($h)->FLAGS & B::SVs_RMG()),
+ "$desc no longer has the RMG flag set");
+ }
}