From: Vincent Pit Date: Sun, 22 Feb 2009 09:03:23 +0000 (+0100) Subject: Move the op_info tests to a new t/18-opinfo.t X-Git-Tag: v0.32~16 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=eca9d54dfe50df3daace0c4aa552289258cf6c68 Move the op_info tests to a new t/18-opinfo.t --- diff --git a/MANIFEST b/MANIFEST index 0f64434..3680990 100644 --- a/MANIFEST +++ b/MANIFEST @@ -20,6 +20,7 @@ t/14-callbacks.t t/15-self.t t/16-huf.t t/17-ctl.t +t/18-opinfo.t t/20-get.t t/21-set.t t/22-len.t diff --git a/t/14-callbacks.t b/t/14-callbacks.t index cc4eb4c..eb72559 100644 --- a/t/14-callbacks.t +++ b/t/14-callbacks.t @@ -3,9 +3,9 @@ use strict; use warnings; -use Test::More tests => 12 + 9 * (5 + 6 + 5); +use Test::More tests => 12; -use Variable::Magic qw/wizard cast dispell VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/; +use Variable::Magic qw/wizard cast/; my $wiz = eval { wizard get => sub { undef } }; is($@, '', 'wizard creation doesn\'t croak'); @@ -65,60 +65,3 @@ is_deeply(\@callers, [ ([ 'main', $0, __LINE__-3 ]) x 2, ], 'caller into callback into eval returns the right thing'); -sub Variable::Magic::TestPkg::foo { } - -my @tests = ( - [ 'len', '@c', undef, 'my $x = @c', [ 'padav', 'B::OP' ] ], - [ 'get', '$c', undef, '++$c', [ 'preinc', 'B::UNOP' ] ], - [ 'get', '$c', '$c = 1', '$c ** 2', [ 'pow', 'B::BINOP' ] ], - [ 'get', '$c', undef, 'my $x = $c', [ 'sassign', 'B::BINOP' ] ], - [ 'get', '$c', undef, '1 if $c', [ 'and', 'B::LOGOP' ] ], - [ 'set', '$c', undef, 'bless \$c, "main"', [ 'bless', 'B::LISTOP' ] ], - [ 'get', '$c', '$c = ""', '$c =~ /x/', [ 'match', 'B::PMOP' ] ], - [ 'get', '$c', '$c = "Variable::Magic::TestPkg"', - '$c->foo()', [ 'method_named', 'B::SVOP' ] ], - [ 'get', '$c', '$c = ""', '$c =~ y/x/y/', [ 'trans', 'B::PVOP' ] ], -); - -for (@tests) { - my ($key, $var, $init, $test, $exp) = @$_; - - for my $op_info (VMG_OP_INFO_NAME, VMG_OP_INFO_OBJECT, 3) { - our $done; - my ($c, @c); - - # We must test for the $op correctness inside the callback because, if we - # bring it out, it will go outside of the eval STRING scope, and what it - # points to will no longer exist. - eval { - $wiz = wizard $key => sub { - return if $done; - my $op = $_[-1]; - my $desc = "$key magic with op_info == $op_info"; - if ($op_info == 1) { - is $op, $exp->[0], "$desc gets the right op info"; - } elsif ($op_info == 2) { - isa_ok $op, $exp->[1], $desc; - is $op->name, $exp->[0], "$desc gets the right op info"; - } else { - is $op, undef, "$desc gets the right op info"; - } - $done = 1; - () - }, op_info => $op_info - }; - is $@, '', "$key wizard with op_info == $op_info doesn't croak"; - - eval $init if defined $init; - - eval "cast $var, \$wiz"; - is $@, '', "$key cast with op_info == $op_info doesn't croak"; - - local $done = 0; - eval $test; - is $@, '', "$key magic with op_info == $op_info doesn't croak"; - - eval "dispell $var, \$wiz"; - is $@, '', "$key dispell with op_info == $op_info doesn't croak"; - } -} diff --git a/t/18-opinfo.t b/t/18-opinfo.t new file mode 100644 index 0000000..12313f8 --- /dev/null +++ b/t/18-opinfo.t @@ -0,0 +1,98 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 11 * (5 + 6) + 5; + +use Config qw/%Config/; + +use Variable::Magic qw/wizard cast dispell VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/; + +sub Variable::Magic::TestPkg::foo { } + +my $aelem = $] <= 5.008003 ? 'aelem' : 'aelemfast'; +my $aelem_op = $Config{useithreads} ? 'B::PADOP' : 'B::SVOP'; + +our @o; + +my @tests = ( + [ 'len', '@c', undef, 'my $x = @c', [ 'padav', 'B::OP' ] ], + [ 'get', '$c[0]', undef, 'my $x = $c[0]', [ $aelem, 'B::OP' ] ], + [ 'get', '$o[0]', undef, 'my $x = $o[0]', [ 'aelemfast', $aelem_op ] ], + [ 'get', '$c', undef, '++$c', [ 'preinc', 'B::UNOP' ] ], + [ 'get', '$c', '$c = 1', '$c ** 2', [ 'pow', 'B::BINOP' ] ], + [ 'get', '$c', undef, 'my $x = $c', [ 'sassign', 'B::BINOP' ] ], + [ 'get', '$c', undef, '1 if $c', [ 'and', 'B::LOGOP' ] ], + [ 'set', '$c', undef, 'bless \$c, "main"', [ 'bless', 'B::LISTOP' ] ], + [ 'get', '$c', '$c = ""', '$c =~ /x/', [ 'match', 'B::PMOP' ] ], + [ 'get', '$c', '$c = "Variable::Magic::TestPkg"', + '$c->foo()', [ 'method_named', 'B::SVOP' ] ], + [ 'get', '$c', '$c = ""', '$c =~ y/x/y/', [ 'trans', 'B::PVOP' ] ], +); + +for (@tests) { + my ($key, $var, $init, $test, $exp) = @$_; + + for my $op_info (VMG_OP_INFO_NAME, VMG_OP_INFO_OBJECT) { + our $done; + my ($c, @c); + my $wiz; + + # We must test for the $op correctness inside the callback because, if we + # bring it out, it will go outside of the eval STRING scope, and what it + # points to will no longer exist. + eval { + $wiz = wizard $key => sub { + return if $done; + my $op = $_[-1]; + my $desc = "$key magic with op_info == $op_info"; + if ($op_info == VMG_OP_INFO_NAME) { + is $op, $exp->[0], "$desc gets the right op info"; + } elsif ($op_info == VMG_OP_INFO_OBJECT) { + isa_ok $op, $exp->[1], $desc; + is $op->name, $exp->[0], "$desc gets the right op info"; + } else { + is $op, undef, "$desc gets the right op info"; + } + $done = 1; + () + }, op_info => $op_info + }; + is $@, '', "$key wizard with op_info == $op_info doesn't croak"; + + local $done = 0; + + eval $init if defined $init; + + eval "cast $var, \$wiz"; + is $@, '', "$key cast with op_info == $op_info doesn't croak"; + + eval $test; + is $@, '', "$key magic with op_info == $op_info doesn't croak"; + + eval "dispell $var, \$wiz"; + is $@, '', "$key dispell with op_info == $op_info doesn't croak"; + } +} + +{ + my $c; + + my $wiz = eval { + wizard get => sub { + is $_[-1], undef, 'get magic with out of bounds op_info'; + }, + op_info => 3; + }; + is $@, '', "get wizard with out of bounds op_info doesn't croak"; + + eval { cast $c, $wiz }; + is $@, '', "get cast with out of bounds op_info doesn't croak"; + + eval { my $x = $c }; + is $@, '', "get magic with out of bounds op_info doesn't croak"; + + eval { dispell $c, $wiz }; + is $@, '', "get dispell with out of bounds op_info doesn't croak"; +}