The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl -T

use strict;
use warnings;

use Test::More;

use B::RecDeparse;

my $brd = B::RecDeparse->new(level => -1);

sub foo { 123 }
sub baz;
my $pkg;
my $coderef;

my @tests = (
 [ e1 => 'foo()',      '123' ],
 [ e2 => 'foo(1)',     '123' ],
 [ e3 => 'foo(@_)',    '123' ],
 [ e4 => 'foo(shift)', '123' ],

 [ n1 => 'bar()',      'bar' ],
 [ n2 => 'bar(1)',     'bar' ],
 [ n3 => 'bar(@_)',    'bar' ],
 [ n4 => 'bar(shift)', 'bar' ],

 [ d1 => 'baz()',      'baz' ],
 [ d2 => 'baz(1)',     'baz' ],
 [ d3 => 'baz(@_)',    'baz' ],
 [ d4 => 'baz(shift)', 'baz' ],

 [ c1 => '$coderef->()',      'coderef' ],
 [ c2 => '$coderef->(1)',     'coderef' ],
 [ c3 => '$coderef->(@_)',    'coderef' ],
 [ c4 => '$coderef->(shift)', 'coderef' ],

 [ m1  => '"pkg"->qux()',      'qux' ],
 [ m2  => '"pkg"->qux(1)',     'qux' ],
 [ m3  => '"pkg"->qux(@_)',    'qux' ],
 [ m4  => '"pkg"->qux(shift)', 'qux' ],
 [ m5  => '$pkg->qux()',       'qux' ],
 [ m6  => '$pkg->qux(1)',      'qux' ],
 [ m7  => '$pkg->qux(@_)',     'qux' ],
 [ m8  => '$pkg->qux(shift)',  'qux' ],
 [ m9  => 'shift->qux()',      'qux' ],
 [ m10 => 'shift->qux(1)',     'qux' ],
 [ m11 => 'shift->qux(@_)',    'qux' ],
 [ m12 => 'shift->qux(shift)', 'qux' ],
);

if (eval 'use List::Util qw<sum>; 1') {
 push @tests, (
  [ x1 => 'sum()',      'sum' ],
  [ x2 => 'sum(1)',     'sum' ],
  [ x3 => 'sum(@_)',    'sum' ],
  [ x4 => 'sum(shift)', 'sum' ],
 );
}

plan tests => 2 * @tests;

for my $test (@tests) {
 my ($name, $source, $match) = @$test;

 my $code = do {
  local $@;
  eval "sub { $source }";
 };

 my $res = eval { $brd->coderef2text($code) };
 is  $@,    '',             "deparsing sub $name doesn't croak";
 $res = '' unless defined $res;
 like $res, qr/\Q$match\E/, "deparsing sub $name works as expected";
}