From: Chia-liang Kao Date: Wed, 27 Jun 2007 00:06:56 +0000 (+0100) Subject: B::Deparse cleanups X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=09d856fb6c15ff72549603f60c58c639d94f8791;p=p5sagit%2Fp5-mst-13.2.git B::Deparse cleanups Message-Id: <1182899216.22414.32.camel@localhost> p4raw-id: //depot/perl@31476 --- diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm index 895a1f1..d0b18be 100644 --- a/ext/B/B/Deparse.pm +++ b/ext/B/B/Deparse.pm @@ -21,7 +21,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED), ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE'); -$VERSION = 0.81; +$VERSION = 0.82; use strict; use vars qw/$AUTOLOAD/; use warnings (); @@ -1107,32 +1107,10 @@ sub lineseq { if defined($self->{'limit_seq'}) && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq); local $self->{'limit_seq'} = $limit_seq; - for (my $i = 0; $i < @ops; $i++) { - $expr = ""; - if (is_state $ops[$i]) { - $expr = $self->deparse($ops[$i], 0); - $i++; - if ($i > $#ops) { - push @exprs, $expr; - last; - } - } - if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and - !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq") - { - if ($ls->first && !null($ls->first) && is_state($ls->first) - && (my $sib = $ls->first->sibling)) { - if (!null($sib) && $sib->name eq "leaveloop") { - push @exprs, $expr . $self->for_loop($ops[$i], 0); - $i++; - next; - } - } - } - $expr .= $self->deparse($ops[$i], (@ops != 1)/2); - $expr =~ s/;\n?\z//; - push @exprs, $expr; - } + + $self->walk_lineseq($root, \@ops, + sub { push @exprs, $_[0]} ); + my $body = join(";\n", grep {length} @exprs); my $subs = ""; if (defined $root && defined $limit_seq && !$self->{'in_format'}) { @@ -1197,28 +1175,31 @@ sub deparse_root { for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) { push @kids, $kid; } + $self->walk_lineseq($op, \@kids, + sub { print $self->indent($_[0].';'); + print "\n" unless $_[1] == $#kids; + }); +} + +sub walk_lineseq { + my ($self, $op, $kids, $callback) = @_; + my @kids = @$kids; for (my $i = 0; $i < @kids; $i++) { my $expr = ""; if (is_state $kids[$i]) { - $expr = $self->deparse($kids[$i], 0); - $i++; + $expr = $self->deparse($kids[$i++], 0); if ($i > $#kids) { - print $self->indent($expr); + $callback->($expr, $i); last; } } if (is_for_loop($kids[$i])) { - $expr .= $self->for_loop($kids[$i], 0); - $expr .= ";\n" unless $i == $#kids; - print $self->indent($expr); - $i++; + $callback->($expr . $self->for_loop($kids[$i], 0), $i++); next; } $expr .= $self->deparse($kids[$i], (@kids != 1)/2); $expr =~ s/;\n?\z//; - $expr .= ";"; - print $self->indent($expr); - print "\n" unless $i == $#kids; + $callback->($expr, $i); } } @@ -1803,8 +1784,7 @@ sub pp_refgen { return $self->anon_hash_or_list($op, $cx); } elsif (!null($kid->sibling) and $kid->sibling->name eq "anoncode") { - return "sub " . - $self->deparse_sub($self->padval($kid->sibling->targ)); + return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) }); } elsif ($kid->name eq "pushmark") { my $sib_name = $kid->sibling->name; if ($sib_name =~ /^(pad|rv2)[ah]v$/ @@ -1825,6 +1805,12 @@ sub pp_refgen { $self->pfixop($op, $cx, "\\", 20); } +sub e_anoncode { + my ($self, $info) = @_; + my $text = $self->deparse_sub($info->{code}); + return "sub " . $text; +} + sub pp_srefgen { pp_refgen(@_) } sub pp_readline { @@ -2679,7 +2665,7 @@ sub loop_common { return $head . "{\n\t" . $body . "\b}" . $cont; } -sub pp_leaveloop { loop_common(@_, "") } +sub pp_leaveloop { shift->loop_common(@_, "") } sub for_loop { my $self = shift; @@ -3080,7 +3066,7 @@ sub want_list { return ($op->flags & OPf_WANT) == OPf_WANT_LIST; } -sub method { +sub _method { my $self = shift; my($op, $cx) = @_; my $kid = $op->first->sibling; # skip pushmark @@ -3102,18 +3088,18 @@ sub method { $obj = $kid; $kid = $kid->sibling; for (; not null $kid; $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); + push @exprs, $kid; } } else { $obj = $kid; $kid = $kid->sibling; for (; !null ($kid->sibling) && $kid->name ne "method_named"; $kid = $kid->sibling) { - push @exprs, $self->deparse($kid, 6); + push @exprs, $kid } $meth = $kid; } - $obj = $self->deparse($obj, 24); + if ($meth->name eq "method_named") { $meth = $self->const_sv($meth)->PV; } else { @@ -3122,12 +3108,28 @@ sub method { # As of 5.005_58, this case is probably obsoleted by the # method_named case above $meth = $self->const_sv($meth)->PV; # needs to be bare - } else { - $meth = $self->deparse($meth, 1); } } - my $args = join(", ", @exprs); - $kid = $obj . "->" . $meth; + + return { method => $meth, variable_method => ref($meth), + object => $obj, args => \@exprs }; +} + +# compat function only +sub method { + my $self = shift; + my $info = $self->_method(@_); + return $self->e_method( $self->_method(@_) ); +} + +sub e_method { + my ($self, $info) = @_; + my $obj = $self->deparse($info->{object}, 24); + + my $meth = $info->{method}; + $meth = $self->deparse($meth, 1) if $info->{variable_method}; + my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} ); + my $kid = $obj . "->" . $meth; if (length $args) { return $kid . "(" . $args . ")"; # parens mandatory } else { @@ -3217,7 +3219,8 @@ sub check_proto { sub pp_entersub { my $self = shift; my($op, $cx) = @_; - return $self->method($op, $cx) unless null $op->first->sibling; + return $self->e_method($self->_method($op, $cx)) + unless null $op->first->sibling; my $prefix = ""; my $amper = ""; my($kid, @exprs); diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t index d723840..9430830 100644 --- a/ext/B/t/concise-xs.t +++ b/ext/B/t/concise-xs.t @@ -117,7 +117,7 @@ use Getopt::Std; use Carp; use Test::More tests => ( # per-pkg tests (function ct + require_ok) 40 + 16 # Data::Dumper, Digest::MD5 - + 517 + 276 # B::Deparse, B + + 521 + 276 # B::Deparse, B + 595 + 190 # POSIX, IO::Socket - 6); # fudge diff --git a/ext/B/t/deparse.t b/ext/B/t/deparse.t index bf1e172..ed14919 100644 --- a/ext/B/t/deparse.t +++ b/ext/B/t/deparse.t @@ -19,18 +19,13 @@ BEGIN { } } -$| = 1; use warnings; use strict; -use Config; - -print "1..47\n"; +use Test::More tests => 50; use B::Deparse; -my $deparse = B::Deparse->new() or print "not "; -my $i=1; -print "ok " . $i++ . "\n"; - +my $deparse = B::Deparse->new(); +ok($deparse); # Tell B::Deparse about our ambient pragmas { my ($hint_bits, $warning_bits); @@ -45,8 +40,8 @@ print "ok " . $i++ . "\n"; $/ = "\n####\n"; while () { chomp; - s/#.*$//mg; - + s/#(.*)$//mg; + my ($num) = $1 =~ m/(\d+)/; my ($input, $expected); if (/(.*)\n>>>>\n(.*)/s) { ($input, $expected) = ($1, $2); @@ -58,8 +53,7 @@ while () { my $coderef = eval "sub {$input}"; if ($@) { - print "not ok " . $i++ . "\n"; - print "# $@"; + ok(0, "$num deparsed: $@"); } else { my $deparsed = $deparse->coderef2text( $coderef ); @@ -67,37 +61,21 @@ while () { $regex =~ s/(\S+)/\Q$1/g; $regex =~ s/\s+/\\s+/g; $regex = '^\{\s*' . $regex . '\s*\}$'; - - my $ok = ($deparsed =~ /$regex/); - print (($ok ? "ok " : "not ok ") . $i++ . "\n"); - if (!$ok) { - print "# EXPECTED:\n"; - $regex =~ s/^/# /mg; - print "$regex\n"; - - print "\n# GOT: \n"; - $deparsed =~ s/^/# /mg; - print "$deparsed\n"; - } + like($deparsed, qr/$regex/); } } use constant 'c', 'stuff'; -print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff'; -print "ok " . $i++ . "\n"; +is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff'); -$a = 0; -print "not " if "{\n (-1) ** \$a;\n}" - ne $deparse->coderef2text(sub{(-1) ** $a }); -print "ok " . $i++ . "\n"; +my $a = 0; +is("{\n (-1) ** \$a;\n}", $deparse->coderef2text(sub{(-1) ** $a })); use constant cr => ['hello']; my $string = "sub " . $deparse->coderef2text(\&cr); my $val = (eval $string)->(); -print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello'; -print "ok " . $i++ . "\n"; +ok( ref($val) eq 'ARRAY' && $val->[0] eq 'hello'); -my $a; my $Is_VMS = $^O eq 'VMS'; my $Is_MacOS = $^O eq 'MacOS'; @@ -126,8 +104,7 @@ $b =~ s/(LINE:)/sub BEGIN { 'XL'->bootstrap; } $1/ if $Is_MacOS; -print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b; -print "ok " . $i++ . "\n"; +is($a, $b); #Re: perlbug #35857, patch #24505 #handle warnings::register-ed packages properly. @@ -146,7 +123,7 @@ use warnings; sub test { my $val = shift; my $res = B::Deparse::Wrapper::getcode($val); - print $res =~ /use warnings/ ? '' : 'not ', 'ok ', $i++, "\n"; + like( $res, qr/use warnings/); } my ($q,$p); my $x=sub { ++$q,++$p }; @@ -268,7 +245,7 @@ my $i; while ($i) { my $z = 1; } continue { $i = 99; } #### # 23 -foreach $i (1, 2) { +foreach my $i (1, 2) { my $z = 1; } #### @@ -346,3 +323,13 @@ my $f = sub { #### # 41 (ibid.) &::::; +#### +# 42 +my $bar; +'Foo'->$bar('orz'); +#### +# 43 +'Foo'->bar('orz'); +#### +# 44 +'Foo'->bar;