]> git.vpit.fr Git - perl/modules/B-RecDeparse.git/blob - t/17-calls.t
Also test calls to code references
[perl/modules/B-RecDeparse.git] / t / 17-calls.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 use Test::More tests => 2 * 4 * 6;
7
8 use B::RecDeparse;
9
10 my $brd = B::RecDeparse->new(level => -1);
11
12 sub foo { 123 }
13 my $pkg;
14 my $coderef;
15
16 my @tests = (
17  [ e1 => 'foo()',      '123' ],
18  [ e2 => 'foo(1)',     '123' ],
19  [ e3 => 'foo(@_)',    '123' ],
20  [ e4 => 'foo(shift)', '123' ],
21
22  [ x1 => 'bar()',      'bar' ],
23  [ x2 => 'bar(1)',     'bar' ],
24  [ x3 => 'bar(@_)',    'bar' ],
25  [ x4 => 'bar(shift)', 'bar' ],
26
27  [ c1 => '$coderef->()',      'coderef' ],
28  [ c2 => '$coderef->(1)',     'coderef' ],
29  [ c3 => '$coderef->(@_)',    'coderef' ],
30  [ c4 => '$coderef->(shift)', 'coderef' ],
31
32  [ m1  => '"pkg"->qux()',      'qux' ],
33  [ m2  => '"pkg"->qux(1)',     'qux' ],
34  [ m3  => '"pkg"->qux(@_)',    'qux' ],
35  [ m4  => '"pkg"->qux(shift)', 'qux' ],
36  [ m5  => '$pkg->qux()',       'qux' ],
37  [ m6  => '$pkg->qux(1)',      'qux' ],
38  [ m7  => '$pkg->qux(@_)',     'qux' ],
39  [ m8  => '$pkg->qux(shift)',  'qux' ],
40  [ m9  => 'shift->qux()',      'qux' ],
41  [ m10 => 'shift->qux(1)',     'qux' ],
42  [ m11 => 'shift->qux(@_)',    'qux' ],
43  [ m12 => 'shift->qux(shift)', 'qux' ],
44 );
45
46 for my $test (@tests) {
47  my ($name, $source, $match) = @$test;
48
49  my $code = do {
50   local $@;
51   eval "sub { $source }";
52  };
53
54  my $res = eval { $brd->coderef2text($code) };
55  is  $@,    '',             "deparsing sub $name doesn't croak";
56  $res = '' unless defined $res;
57  like $res, qr/\Q$match\E/, "deparsing sub $name works as expected";
58 }