t/17-calls.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 use B::RecDeparse;
   9
  10 my $brd = B::RecDeparse->new(level => -1);
  11
  12 sub foo { 123 }
  13 sub baz;
  14 my $pkg;
  15 my $coderef;
  16
  17 my @tests = (
  18  [ e1 => 'foo()',      '123' ],
  19  [ e2 => 'foo(1)',     '123' ],
  20  [ e3 => 'foo(@_)',    '123' ],
  21  [ e4 => 'foo(shift)', '123' ],
  22
  23  [ n1 => 'bar()',      'bar' ],
  24  [ n2 => 'bar(1)',     'bar' ],
  25  [ n3 => 'bar(@_)',    'bar' ],
  26  [ n4 => 'bar(shift)', 'bar' ],
  27
  28  [ d1 => 'baz()',      'baz' ],
  29  [ d2 => 'baz(1)',     'baz' ],
  30  [ d3 => 'baz(@_)',    'baz' ],
  31  [ d4 => 'baz(shift)', 'baz' ],
  32
  33  [ c1 => '$coderef->()',      'coderef' ],
  34  [ c2 => '$coderef->(1)',     'coderef' ],
  35  [ c3 => '$coderef->(@_)',    'coderef' ],
  36  [ c4 => '$coderef->(shift)', 'coderef' ],
  37
  38  [ m1  => '"pkg"->qux()',      'qux' ],
  39  [ m2  => '"pkg"->qux(1)',     'qux' ],
  40  [ m3  => '"pkg"->qux(@_)',    'qux' ],
  41  [ m4  => '"pkg"->qux(shift)', 'qux' ],
  42  [ m5  => '$pkg->qux()',       'qux' ],
  43  [ m6  => '$pkg->qux(1)',      'qux' ],
  44  [ m7  => '$pkg->qux(@_)',     'qux' ],
  45  [ m8  => '$pkg->qux(shift)',  'qux' ],
  46  [ m9  => 'shift->qux()',      'qux' ],
  47  [ m10 => 'shift->qux(1)',     'qux' ],
  48  [ m11 => 'shift->qux(@_)',    'qux' ],
  49  [ m12 => 'shift->qux(shift)', 'qux' ],
  50 );
  51
  52 if (eval 'use List::Util qw<sum>; 1') {
  53  push @tests, (
  54   [ x1 => 'sum()',      'sum' ],
  55   [ x2 => 'sum(1)',     'sum' ],
  56   [ x3 => 'sum(@_)',    'sum' ],
  57   [ x4 => 'sum(shift)', 'sum' ],
  58  );
  59 }
  60
  61 plan tests => 2 * @tests;
  62
  63 for my $test (@tests) {
  64  my ($name, $source, $match) = @$test;
  65
  66  my $code = do {
  67   local $@;
  68   eval "sub { $source }";
  69  };
  70
  71  my $res = eval { $brd->coderef2text($code) };
  72  is  $@,    '',             "deparsing sub $name doesn't croak";
  73  $res = '' unless defined $res;
  74  like $res, qr/\Q$match\E/, "deparsing sub $name works as expected";
  75 }