6 use blib 't/Sub-Op-LexicalSub';
8 use Test::More tests => 2 * ((2 + 2) * 4 + (1 + 2) * 5) + 2 * (2 + 2) + 4 + 4;
11 sub foo { ok $call_foo, 'the preexistent foo was called' }
14 sub bar () { ok $call_bar, 'the preexistent bar was called' }
19 sub blech { ok $call_blech, 'initial blech was called' };
22 sub wat { is_deeply \@_, $wat_args, 'wat was called with the right arguments' }
32 my ($code, $params) = split /----\s*/, $_;
33 my ($names, $ret, $exp, $seq) = split /\s*#\s*/, $params;
35 my @names = split /\s*,\s*/, $names;
39 fail "@names: unable to get expected values: $@";
46 s/^\s*//, s/\s*$// for $seq;
47 @seq = split /\s*,\s*/, $seq;
48 die "calls and seq length mismatch" unless @seq == $calls;
50 @seq = ($names[0]) x $calls;
54 for my $name (@names) {
56 use Sub::Op::LexicalSub $name => sub {
58 my \$exp = shift \@exp;
59 is_deeply \\\@_, \$exp, '$name: arguments are correct';
60 my \$seq = shift \@seq;
61 is \$seq, '$name', '$name: sequence is correct';
66 $test .= "{\n$code\n}\n";
68 for my $name (grep +{ map +($_, 1), qw/foo bar blech/ }->{ $_ }, @names) {
69 $test .= <<" CHECK_SUB"
71 local \$call_$name = 1;
81 fail "@names: unable to evaluate test case: $@";
85 is $called, $calls, "@names: the hook was called the right number of times";
86 if ($called < $calls) {
87 fail, fail for $called + 1 .. $calls;
94 use Sub::Op::LexicalSub what => \&wat;
95 local $wat_args = [ 1 ];
97 local $wat_args = [ 2, 3 ];
99 local $wat_args = [ 4, 5 ];
104 is $@, '', 'what: no errors';
107 is prototype('main::foo'), undef, "foo's prototype was preserved";
108 is prototype('main::bar'), '', "bar's prototype was preserved";
109 is prototype('main::X'), '', "X's prototype was preserved";
110 ok Sub::Op::_constant_sub(do { no strict "refs"; \&{"main::X"} }),
111 'X is still a constant';
200 is X, 2, 'constant overriding';
204 no warnings 'redefine';
205 sub blech { fail 'redefined blech was called' }
206 BEGIN { $call_blech = 0 }
208 BEGIN { $call_blech = 1 }