From: Vincent Pit Date: Sun, 27 Feb 2011 18:44:50 +0000 (+0100) Subject: Stop tripping on special function calls. X-Git-Tag: rt63842^0 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=3f86aade0125d81087495585dc71c827858428be;p=perl%2Fmodules%2FB-RecDeparse.git Stop tripping on special function calls. Like calls to an undefined subroutine or that involve @_ and friends. This solves RT #63842. --- diff --git a/MANIFEST b/MANIFEST index a2af981..b67812f 100644 --- a/MANIFEST +++ b/MANIFEST @@ -14,6 +14,7 @@ t/13-prototypes.t t/14-refs.t t/15-pkg.t t/16-recurse.t +t/17-calls.t t/20-compile.t t/21-single_delim.t t/91-pod.t diff --git a/lib/B/RecDeparse.pm b/lib/B/RecDeparse.pm index 89d695c..12df138 100644 --- a/lib/B/RecDeparse.pm +++ b/lib/B/RecDeparse.pm @@ -183,10 +183,11 @@ sub pp_gv { my $gv = $self->gv_or_padgv($_[0]); my $name = $gv->NAME; + my $cv = $gv->CV; my $seen = $self->{brd_seen}; my $body; - if (!$self->{brd_sub} or !$self->_recurse or $seen->{$name}) { + if (!$self->{brd_sub} or !$self->_recurse or $seen->{$name} or !$$cv) { $body = $self->SUPER::pp_gv(@_); } else { $body = do { diff --git a/t/17-calls.t b/t/17-calls.t new file mode 100644 index 0000000..8db7ac4 --- /dev/null +++ b/t/17-calls.t @@ -0,0 +1,52 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 2 * 4 * 5; + +use B::RecDeparse; + +my $brd = B::RecDeparse->new(level => -1); + +sub foo { 123 } +my $pkg; + +my @tests = ( + [ e1 => 'foo()', '123' ], + [ e2 => 'foo(1)', '123' ], + [ e3 => 'foo(@_)', '123' ], + [ e4 => 'foo(shift)', '123' ], + + [ x1 => 'bar()', 'bar' ], + [ x2 => 'bar(1)', 'bar' ], + [ x3 => 'bar(@_)', 'bar' ], + [ x4 => 'bar(shift)', 'bar' ], + + [ 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' ], +); + +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"; +}