X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FB%2FRecDeparse.pm;h=a9ace562920d0a516f32958bcc93b4f41f35e9a6;hb=055d88b751d7e3d19bb94c3d734bbfcedee19276;hp=15adc0772360445eca3ff56942e68b1c2cd8402e;hpb=76a250f484c0e33ec23349591be56ee4ba2aa567;p=perl%2Fmodules%2FB-RecDeparse.git diff --git a/lib/B/RecDeparse.pm b/lib/B/RecDeparse.pm index 15adc07..a9ace56 100644 --- a/lib/B/RecDeparse.pm +++ b/lib/B/RecDeparse.pm @@ -5,9 +5,11 @@ use 5.008; use strict; use warnings; +use B (); + use Config; -use base qw/B::Deparse/; +use base qw; =head1 NAME @@ -81,9 +83,13 @@ sub _parse_args { sub new { my $class = shift; $class = ref($class) || $class || __PACKAGE__; + my ($deparse, $level) = _parse_args(@_); + my $self = bless $class->SUPER::new(@$deparse), $class; + $self->{brd_level} = $level; + return $self; } @@ -92,22 +98,28 @@ sub _recurse { } sub compile { - my $bd = B::Deparse->new(); my @args = @_; + + my $bd = B::Deparse->new(); my ($deparse, $level) = _parse_args(@args); + my $compiler = $bd->coderef2text(B::Deparse::compile(@$deparse)); $compiler =~ s/ ['"]? B::Deparse ['"]? \s* -> \s* (new) \s* \( ([^\)]*) \) /B::RecDeparse->$1(deparse => [ $2 ], level => $level)/gx; $compiler = eval 'sub ' . $compiler; die if $@; + return $compiler; } sub init { my $self = shift; - $self->{brd_cur} = 0; - $self->{brd_sub} = 0; + + $self->{brd_cur} = 0; + $self->{brd_sub} = 0; + $self->{brd_seen} = { }; + $self->SUPER::init(@_); } @@ -115,9 +127,11 @@ my $key = $; . __PACKAGE__ . $;; if (FOOL_SINGLE_DELIM) { my $oldsd = *B::Deparse::single_delim{CODE}; + no warnings 'redefine'; *B::Deparse::single_delim = sub { my $body = $_[2]; + if ((caller 1)[0] eq __PACKAGE__ and $body =~ s/^$key//) { return $body; } else { @@ -126,18 +140,35 @@ if (FOOL_SINGLE_DELIM) { } } +sub deparse_sub { + my $self = shift; + my $cv = $_[0]; + + my $name; + unless ($cv->CvFLAGS & B::CVf_ANON()) { + $name = $cv->GV->SAFENAME; + } + + local $self->{brd_seen}->{$name} = 1 if defined $name; + return $self->SUPER::deparse_sub(@_); +} + sub pp_entersub { my $self = shift; + my $body = do { local $self->{brd_sub} = 1; $self->SUPER::pp_entersub(@_); }; + $body =~ s/^&\s*(\w)/$1/ if $self->_recurse; + return $body; } sub pp_refgen { my $self = shift; + return do { local $self->{brd_sub} = 0; $self->SUPER::pp_refgen(@_); @@ -146,21 +177,28 @@ sub pp_refgen { sub pp_gv { my $self = shift; + + my $gv = $self->gv_or_padgv($_[0]); + my $name = $gv->NAME; + my $seen = $self->{brd_seen}; + my $body; - if ($self->{brd_sub} <= 0 || !$self->_recurse) { + if ($self->{brd_sub} <= 0 || !$self->_recurse || $seen->{$name}) { $body = $self->SUPER::pp_gv(@_); } else { - my $gv = $self->gv_or_padgv($_[0]); $body = do { - local @{$self}{qw/brd_sub brd_cur/} = (0, $self->{brd_cur} + 1); + local @{$self}{qw} = (0, $self->{brd_cur} + 1); + local $seen->{$name} = 1; 'sub ' . $self->indent($self->deparse_sub($gv->CV)); }; + if (FOOL_SINGLE_DELIM) { $body = $key . $body; } else { $body .= '->'; } } + return $body; } @@ -168,6 +206,8 @@ sub pp_gv { =head2 C +=head2 C + =head2 C =head2 C @@ -206,7 +246,7 @@ Tests code coverage report is available at L