X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=t%2F18-opinfo.t;h=00133452d76d8acdb0ca8adcb2da5b833aaee0e3;hb=cdc5231a1c56c4eb1d731e59eb5b525477e538b6;hp=c10ccb063cf0e1cdd300f3348d263ac7858fffc4;hpb=7d7ecf0199c007b554b0d8297c1486edfcb99464;p=perl%2Fmodules%2FVariable-Magic.git diff --git a/t/18-opinfo.t b/t/18-opinfo.t index c10ccb0..0013345 100644 --- a/t/18-opinfo.t +++ b/t/18-opinfo.t @@ -3,40 +3,79 @@ use strict; use warnings; -use Test::More tests => 11 * (5 + 6) + 4 + 5; +use Test::More tests => 19 * (3 + 4) + 5 + 1; -use Config qw/%Config/; +use Config qw<%Config>; -use Variable::Magic qw/wizard cast dispell VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/; +use Variable::Magic qw; sub Variable::Magic::TestPkg::foo { } -my $aelem = $] <= 5.008003 ? 'aelem' : 'aelemfast'; -my $aelem_op = $Config{useithreads} ? 'B::PADOP' : 'B::SVOP'; +my $is_5130_release = ("$]" == 5.013 && !$Config{git_describe}) ? 1 : 0; + +my $aelem = "$]" <= 5.008_003 ? 'aelem' + : ("$]" < 5.013 or $is_5130_release) + ? 'aelemfast' + : ("$]" < 5.037_003) + ? 'sassign' + : 'padsv_store'; +my $aelemf = ("$]" < 5.013 or $is_5130_release) ? 'aelemfast' + : ("$]" < 5.037_003) ? 'sassign' + : 'padsv_store'; + +my $assign_op = ("$]" < 5.037_003) ? 'sassign': 'padsv_store'; +my $assign_op_cl = ("$]" < 5.037_003) ? 'B::BINOP': 'B::UNOP'; + +my $aelemf_op = ($aelemf eq 'sassign') ? 'B::BINOP' + : ($aelemf eq 'padsv_store') ? 'B::UNOP' + : $Config{useithreads} ? 'B::PADOP' : 'B::SVOP'; +my $meth_op = ("$]" < 5.021_005) ? 'B::SVOP' : 'B::METHOP'; +my $trutf_op = ($Config{useithreads} && "$]" >= 5.008_009) + ? 'B::PADOP' : 'B::SVOP'; +my $deref = ("$]" < 5.021_007) ? 'helem' : 'multideref'; +my $deref_op = ($deref eq 'multideref') ? 'B::UNOP_AUX' : 'B::UNOP'; 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' ] ], + [ 'len', '@c', 'my @c', 'my $x = @c', [ 'padav', 'B::OP' ] ], + [ 'get', '$c[0]', 'my @c', 'my $x = $c[0]; 1', + [ $aelem, 'B::OP' ] ], + [ 'get', '$o[0]', 'local @o', 'my $x = $o[0]; 1', + [ $aelemf, $aelemf_op ] ], + [ 'get', '$x->{a}', 'my $x', 'my $y = $x->{a}{b}', + [ $deref, $deref_op ] ], + [ 'get', '$c', 'my $c = 1', '++$c', [ 'preinc', 'B::UNOP' ] ], + [ 'get', '$c', 'my $c = 1', '$c ** 2', [ 'pow', 'B::BINOP' ] ], + [ 'get', '$c', 'my $c = 1', 'my $x = $c; 1', [ $assign_op, $assign_op_cl ] ], + [ 'get', '$c', 'my $c = 1', '1 if $c', [ 'and', 'B::LOGOP' ] ], + [ 'get', '$c', 'my $c = []', 'ref $c', [ 'ref', 'B::UNOP' ] ], + [ 'get', '$c', 'my $c = $0', '-f $c', [ 'ftfile', 'B::UNOP' ] ], + [ 'get', '$c', 'my $c = "Z"', + 'my $i = 1; Z:goto $c if $i--', [ 'goto', 'B::UNOP' ] ], + [ 'set', '$c', 'my $c = 1', 'bless \$c, "main"', + [ 'bless', 'B::LISTOP' ] ], + [ 'get', '$c', 'my $c = ""', '$c =~ /x/', [ 'match', 'B::PMOP' ] ], + [ 'get', '$c', 'my $c = "Variable::Magic::TestPkg"', + '$c->foo()', [ 'method_named', $meth_op ] ], + [ 'get', '$c', 'my $c = ""', '$c =~ y/x/y/', [ 'trans', 'B::PVOP' ] ], + [ 'get', '$c', 'my $c = ""', '$c =~ y/\x{100}//', + [ 'trans', $trutf_op ] ], + [ 'get', '$c', 'my $c = 1', '1 for 1 .. $c', + [ 'enteriter', 'B::LOOP' ] ], + [ 'free','$c', 'my $c = 1', 'last', [ 'last', 'B::OP' ] ], + [ 'free','$c', 'L:{my $c = 1', 'last L}', [ 'last', 'B::OP' ] ], ); +our $done; + +my $OP_INFO_NAME = VMG_OP_INFO_NAME; +my $OP_INFO_OBJECT = VMG_OP_INFO_OBJECT; + 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); + for my $op_info ($OP_INFO_NAME, $OP_INFO_OBJECT) { my $wiz; # We must test for the $op correctness inside the callback because, if we @@ -47,9 +86,9 @@ for (@tests) { return if $done; my $op = $_[-1]; my $desc = "$key magic with op_info == $op_info"; - if ($op_info == VMG_OP_INFO_NAME) { + if ($op_info == $OP_INFO_NAME) { is $op, $exp->[0], "$desc gets the right op info"; - } elsif ($op_info == VMG_OP_INFO_OBJECT) { + } elsif ($op_info == $OP_INFO_OBJECT) { isa_ok $op, $exp->[1], $desc; is $op->name, $exp->[0], "$desc gets the right op info"; } else { @@ -63,38 +102,14 @@ for (@tests) { local $done = 0; - eval $init if defined $init; - - eval "cast $var, \$wiz"; - is $@, '', "$key cast with op_info == $op_info doesn't croak"; + my $testcase = "{ $init; cast $var, \$wiz; $test }"; - eval $test; + eval $testcase; 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"; + diag $testcase if $@; } } -{ - my $c; - - my $op_info = VMG_OP_INFO_OBJECT; - my $wiz = eval { - wizard free => sub { - my $op = $_[-1]; - my $desc = "free magic with op_info == $op_info"; - isa_ok $op, 'B::OP', $desc; - is $op->name, 'leaveloop', "$desc gets the right op info"; - (); - }, op_info => $op_info; - }; - 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"; -} - { my $c; @@ -115,3 +130,13 @@ for (@tests) { eval { dispell $c, $wiz }; is $@, '', "get dispell with out of bounds op_info doesn't croak"; } + +{ + local $@; + my $wiz = eval { + local $SIG{__WARN__} = sub { die @_ }; + wizard op_info => "hlagh"; + }; + like $@, qr/^Argument "hlagh" isn't numeric in subroutine entry at \Q$0\E/, + 'wizard(op_info => "text") throws numeric warnings'; +}