This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #47359] Deparse method {$object} correctly
authorFather Chrysostomos <sprout@cpan.org>
Wed, 7 Dec 2011 16:39:59 +0000 (08:39 -0800)
committerFather Chrysostomos <sprout@cpan.org>
Wed, 7 Dec 2011 16:42:06 +0000 (08:42 -0800)
The block is evaluated in list context, allowing things like
SUPER::glelp{@_} to work, so deparsing it as do{...}->method is wrong,
as it puts the block in scalar context.

dist/B-Deparse/Deparse.pm
dist/B-Deparse/t/deparse.t

index ed5493b..8aecf88 100644 (file)
@@ -3305,7 +3305,8 @@ sub _method {
     }
 
     return { method => $meth, variable_method => ref($meth),
-             object => $obj, args => \@exprs  };
+             object => $obj, args => \@exprs  },
+          $cx;
 }
 
 # compat function only
@@ -3316,12 +3317,22 @@ sub method {
 }
 
 sub e_method {
-    my ($self, $info) = @_;
+    my ($self, $info, $cx) = @_;
     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}} );
+    if ($info->{object}->name eq 'scope' && want_list $info->{object}) {
+       # method { $object }
+       # This must be deparsed this way to preserve list context
+       # of $object.
+       my $need_paren = $cx >= 6;
+       return '(' x $need_paren
+            . $meth . substr($obj,2) # chop off the "do"
+            . " $args"
+            . ')' x $need_paren;
+    }
     my $kid = $obj . "->" . $meth;
     if (length $args) {
        return $kid . "(" . $args . ")"; # parens mandatory
index a4284ef..a81c86e 100644 (file)
@@ -410,6 +410,17 @@ my $bar;
 # constants as method names without ()
 'Foo'->bar;
 ####
+# "indirect" method call notation
+our @bar;
+foo{@bar}+1,->foo;
+(foo{@bar}+1),foo();
+foo{@bar}1 xor foo();
+>>>>
+our @bar;
+(foo { @bar } 1)->foo;
+(foo { @bar } 1), foo();
+foo { @bar } 1 xor foo();
+####
 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
 # say
 say 'foo';