From: Vincent Pit <vince@profvince.com>
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";
+}