6 use Test::More tests => 17 * (3 + 4) + 5;
8 use Config qw/%Config/;
10 use Variable::Magic qw/wizard cast dispell VMG_OP_INFO_NAME VMG_OP_INFO_OBJECT/;
12 sub Variable::Magic::TestPkg::foo { }
14 my $is_5130_release = ($] == 5.013 && !$Config{git_describe}) ? 1 : 0;
16 my $aelem = $] <= 5.008003 ? 'aelem'
17 : ($] < 5.013 or $is_5130_release) ? 'aelemfast'
19 my $aelemf = ($] < 5.013 or $is_5130_release) ? 'aelemfast' : 'sassign';
20 my $aelemf_op = $aelemf eq 'sassign'
21 ? 'B::BINOP' : $Config{useithreads} ? 'B::PADOP' : 'B::SVOP';
26 [ 'len', '@c', 'my @c', 'my $x = @c', [ 'padav', 'B::OP' ] ],
27 [ 'get', '$c[0]', 'my @c', 'my $x = $c[0]', [ $aelem, 'B::OP' ] ],
28 [ 'get', '$o[0]', 'local @o', 'my $x = $o[0]', [ $aelemf, $aelemf_op ] ],
29 [ 'get', '$c', 'my $c = 1', '++$c', [ 'preinc', 'B::UNOP' ] ],
30 [ 'get', '$c', 'my $c = 1', '$c ** 2', [ 'pow', 'B::BINOP' ] ],
31 [ 'get', '$c', 'my $c = 1', 'my $x = $c', [ 'sassign', 'B::BINOP' ] ],
32 [ 'get', '$c', 'my $c = 1', '1 if $c', [ 'and', 'B::LOGOP' ] ],
33 [ 'get', '$c', 'my $c = []','ref $c', [ 'ref', 'B::UNOP' ] ],
34 [ 'get', '$c', 'my $c = $0','-f $c', [ 'ftfile', 'B::UNOP' ] ],
35 [ 'get', '$c', 'my $c = "Z"',
36 'my $i = 1; Z:goto $c if $i--', [ 'goto', 'B::UNOP' ] ],
37 [ 'set', '$c', 'my $c = 1', 'bless \$c, "main"',
38 [ 'bless', 'B::LISTOP' ] ],
39 [ 'get', '$c', 'my $c = ""','$c =~ /x/', [ 'match', 'B::PMOP' ] ],
40 [ 'get', '$c', 'my $c = "Variable::Magic::TestPkg"',
41 '$c->foo()', [ 'method_named', 'B::SVOP' ] ],
42 [ 'get', '$c', 'my $c = ""','$c =~ y/x/y/', [ 'trans', 'B::PVOP' ] ],
43 [ 'get', '$c', 'my $c = 1', '1 for 1 .. $c',
44 [ 'enteriter', 'B::LOOP' ] ],
45 [ 'free','$c', 'my $c = 1', 'last', [ 'last', 'B::OP' ] ],
46 [ 'free','$c', 'L:{my $c = 1', 'last L}', [ 'last', 'B::OP' ] ],
52 my ($key, $var, $init, $test, $exp) = @$_;
54 for my $op_info (VMG_OP_INFO_NAME, VMG_OP_INFO_OBJECT) {
57 # We must test for the $op correctness inside the callback because, if we
58 # bring it out, it will go outside of the eval STRING scope, and what it
59 # points to will no longer exist.
61 $wiz = wizard $key => sub {
64 my $desc = "$key magic with op_info == $op_info";
65 if ($op_info == VMG_OP_INFO_NAME) {
66 is $op, $exp->[0], "$desc gets the right op info";
67 } elsif ($op_info == VMG_OP_INFO_OBJECT) {
68 isa_ok $op, $exp->[1], $desc;
69 is $op->name, $exp->[0], "$desc gets the right op info";
71 is $op, undef, "$desc gets the right op info";
75 }, op_info => $op_info
77 is $@, '', "$key wizard with op_info == $op_info doesn't croak";
81 my $testcase = "{ $init; cast $var, \$wiz; $test }";
84 is $@, '', "$key magic with op_info == $op_info doesn't croak";
94 is $_[-1], undef, 'get magic with out of bounds op_info';
98 is $@, '', "get wizard with out of bounds op_info doesn't croak";
100 eval { cast $c, $wiz };
101 is $@, '', "get cast with out of bounds op_info doesn't croak";
104 is $@, '', "get magic with out of bounds op_info doesn't croak";
106 eval { dispell $c, $wiz };
107 is $@, '', "get dispell with out of bounds op_info doesn't croak";