use Test::More;
-use Variable::Magic qw/wizard cast dispell VMG_UVAR VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/;
+use Variable::Magic qw<
+ wizard cast dispell
+ VMG_UVAR VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT
+>;
my $run;
if (VMG_UVAR) {
- plan tests => 13;
+ plan tests => 43;
$run = 1;
} else {
plan skip_all => 'uvar magic is required to test symbol table hooks';
()
}
CB
-} qw/fetch store exists delete/);
+} qw<fetch store exists delete>);
$code .= ', data => sub { +{ guard => 0 } }';
my $wiz = eval $code;
diag $@ if $@;
-{
- no strict 'refs';
- cast %{"Hlagh::"}, $wiz;
-}
+cast %Hlagh::, $wiz;
{
local %mg;
eval q{
die "ok\n";
package Hlagh;
- our $a;
+ our $thing;
{
package NotHlagh;
- our $x = @Hlagh::b;
+ our $what = @Hlagh::stuff;
}
};
is $@, "ok\n", 'stash: variables compiled fine';
is_deeply \%mg, {
- fetch => [ qw/a b/ ],
- store => [ qw/a b/ ],
+ fetch => [ qw<thing stuff> ],
+ store => [ qw<thing stuff> ],
}, 'stash: variables';
}
+{
+ local %mg;
+
+ eval q[
+ die "ok\n";
+ package Hlagh;
+ sub eat;
+ sub shoot;
+ sub leave { "bye" };
+ sub shoot { "bang" };
+ ];
+
+ is $@, "ok\n", 'stash: function definitions compiled fine';
+ is_deeply \%mg, {
+ store => [ qw<eat shoot leave shoot> ],
+ }, 'stash: function definitions';
+}
+
{
local %mg;
eval q{
die "ok\n";
package Hlagh;
- foo();
- bar();
- foo();
+ eat();
+ shoot();
+ leave();
+ roam();
+ yawn();
+ roam();
};
+ my @calls = qw<eat shoot leave roam yawn roam>;
+ my (@fetch, @store);
+ if ("$]" < 5.011_002) {
+ @fetch = @calls;
+ @store = @calls;
+ } elsif ("$]" < 5.021_004) {
+ @fetch = @calls;
+ @store = map { ($_) x 2 } @calls;
+ } else {
+ @fetch = map { ($_) x 2 } @calls;
+ @store = @calls;
+ }
+
is $@, "ok\n", 'stash: function calls compiled fine';
is_deeply \%mg, {
- fetch => [ qw/foo bar foo/ ],
- store => [ qw/foo bar foo/ ],
+ fetch => \@fetch,
+ store => \@store,
}, 'stash: function calls';
}
{
local %mg;
+ eval q{ Hlagh->shoot() };
+
+ is $@, '', 'stash: valid method call ran fine';
+ is_deeply \%mg, {
+ fetch => [ qw<shoot> ],
+ }, 'stash: valid method call';
+}
+
+{
+ local %mg;
+
+ eval q{ Hlagh->shoot() };
+
+ is $@, '', 'stash: second valid method call ran fine';
+ is_deeply \%mg, {
+ fetch => [ qw<shoot> ],
+ }, 'stash: second valid method call';
+}
+
+{
+ local %mg;
+
+ eval q{ my $meth = 'shoot'; Hlagh->$meth() };
+
+ is $@, '', 'stash: valid dynamic method call ran fine';
+ is_deeply \%mg, {
+ store => [ qw<shoot> ],
+ }, 'stash: valid dynamic method call';
+}
+
+{
+ local %mg;
+
+ eval q[
+ package Hlagher;
+ our @ISA;
+ BEGIN { @ISA = 'Hlagh' }
+ Hlagher->leave()
+ ];
+
+ is $@, '', 'inherited valid method call ran fine';
+ is_deeply \%mg, {
+ fetch => [ qw<ISA leave> ],
+ }, 'stash: inherited valid method call';
+}
+
+{
+ local %mg;
+
+ eval q{ Hlagher->leave() };
+
+ is $@, '', 'second inherited valid method call ran fine';
+ is_deeply \%mg, { }, 'stash: second inherited valid method call doesn\'t call magic';
+}
+
+{
+ local %mg;
+
+ eval q{ Hlagher->shoot() };
+
+ is $@, '', 'inherited previously called valid method call ran fine';
+ is_deeply \%mg, {
+ fetch => [ qw<shoot> ],
+ }, 'stash: inherited previously called valid method call';
+}
+
+{
+ local %mg;
+
+ eval q{ Hlagher->shoot() };
+
+ is $@, '', 'second inherited previously called valid method call ran fine';
+ is_deeply \%mg, { }, 'stash: second inherited previously called valid method call doesn\'t call magic';
+}
+
+{
+ local %mg;
+
+ eval q{ Hlagh->unknown() };
+
+ like $@, qr/^Can't locate object method "unknown" via package "Hlagh"/, 'stash: invalid method call croaked';
+ is_deeply \%mg, {
+ fetch => [ qw<unknown> ],
+ store => [ qw<unknown AUTOLOAD> ],
+ }, 'stash: invalid method call';
+}
+
+{
+ local %mg;
+
+ eval q{ my $meth = 'unknown_too'; Hlagh->$meth() };
+
+ like $@, qr/^Can't locate object method "unknown_too" via package "Hlagh"/, 'stash: invalid dynamic method call croaked';
+ is_deeply \%mg, {
+ store => [ qw<unknown_too AUTOLOAD> ],
+ }, 'stash: invalid dynamic method call';
+}
+
+{
+ local %mg;
+
+ eval q{ Hlagher->also_unknown() };
+
+ like $@, qr/^Can't locate object method "also_unknown" via package "Hlagher"/, 'stash: invalid inherited method call croaked';
+ is_deeply \%mg, {
+ fetch => [ qw<also_unknown AUTOLOAD> ],
+ }, 'stash: invalid method call';
+}
+
+{
+ local %mg;
+
+ my @expected_stores = qw<nevermentioned eat shoot>;
+ @expected_stores = map { ($_) x 2 } @expected_stores if "$]" < 5.017_004;
+ push @expected_stores, 'nevermentioned' if "$]" < 5.017_001;
+
eval q{
package Hlagh;
- undef &foo;
+ undef &nevermentioned;
+ undef &eat;
+ undef &shoot;
};
is $@, '', 'stash: delete executed fine';
- is_deeply \%mg, {
- store => [ qw/foo foo foo/ ],
- }, 'stash: delete';
+ is_deeply \%mg, { store => \@expected_stores }, 'stash: delete';
}
END {
is_deeply \%mg, { }, 'stash: magic that remains at END time' if $run;
}
+dispell %Hlagh::, $wiz;
+
{
- no strict 'refs';
- dispell %{"Hlagh::"}, $wiz;
+ package AutoHlagh;
+
+ use vars qw<$AUTOLOAD>;
+
+ sub AUTOLOAD { return $AUTOLOAD }
}
+cast %AutoHlagh::, $wiz;
+
+{
+ local %mg;
+
+ my $res = eval q{ AutoHlagh->autoloaded() };
+
+ is $@, '', 'stash: autoloaded method call ran fine';
+ is $res, 'AutoHlagh::autoloaded',
+ 'stash: autoloaded method call returned the right thing';
+ is_deeply \%mg, {
+ fetch => [ qw<autoloaded> ],
+ store => [ qw<autoloaded AUTOLOAD AUTOLOAD> ],
+ }, 'stash: autoloaded method call';
+}
+
+{
+ package AutoHlagher;
+
+ our @ISA;
+ BEGIN { @ISA = ('AutoHlagh') }
+}
+
+{
+ local %mg;
+
+ my $res = eval q{ AutoHlagher->also_autoloaded() };
+
+ is $@, '', 'stash: inherited autoloaded method call ran fine';
+ is $res, 'AutoHlagher::also_autoloaded',
+ 'stash: inherited autoloaded method returned the right thing';
+ is_deeply \%mg, {
+ fetch => [ qw<also_autoloaded AUTOLOAD> ],
+ store => [ qw<AUTOLOAD> ],
+ }, 'stash: inherited autoloaded method call';
+}
+
+dispell %AutoHlagh::, $wiz;
+
+my $uo = 0;
$code = 'wizard '
. join (', ', map { <<CB;
$_ => sub {
my \$d = \$_[1];
return 0 if \$d->{guard};
local \$d->{guard} = 1;
- is \$_[3], undef, 'stash: undef op';
+ ++\$uo;
()
}
CB
-} qw/fetch store exists delete/);
+} qw<fetch store exists delete>);
+
+my $uo_exp = "$]" < 5.011_002 ? 2 : 3;
$code .= ', data => sub { +{ guard => 0 } }';
$wiz = eval $code . ', op_info => ' . VMG_OP_INFO_NAME;
diag $@ if $@;
-{
- no strict 'refs';
- cast %{"Hlagh::"}, $wiz;
-}
+cast %Hlagh::, $wiz;
+is $uo, 0, 'stash: no undef op before function call with op name';
eval q{
die "ok\n";
package Hlagh;
meh();
};
+is $@, "ok\n", 'stash: function call with op name compiled fine';
+is $uo, $uo_exp, 'stash: undef op after function call with op name';
-is $@, "ok\n", 'stash: function call with op name compiled fine';
+dispell %Hlagh::, $wiz;
+is $uo, $uo_exp, 'stash: undef op after dispell for function call with op name';
-{
- no strict 'refs';
- dispell %{"Hlagh::"}, $wiz;
-}
+$uo = 0;
$wiz = eval $code . ', op_info => ' . VMG_OP_INFO_OBJECT;
diag $@ if $@;
-{
- no strict 'refs';
- cast %{"Hlagh::"}, $wiz;
-}
+cast %Hlagh::, $wiz;
+is $uo, 0, 'stash: no undef op before function call with op object';
eval q{
die "ok\n";
package Hlagh;
wat();
};
+is $@, "ok\n", 'stash: function call with op object compiled fine';
+is $uo, $uo_exp,
+ 'stash: undef op after dispell for function call with op object';
-is $@, "ok\n", 'stash: function call with op object compiled fine';
-
-{
- no strict 'refs';
- dispell %{"Hlagh::"}, $wiz;
-}
+dispell %Hlagh::, $wiz;
+is $uo, $uo_exp,
+ 'stash: undef op after dispell for function call with op object';
projects / perl / modules / Variable-Magic.git / blobdiff