Deparse inlined constants.

Message-Id: <1226608453-25937-2-git-send-email-rafl@debian.org>

p4raw-id: //depot/perl@34844

diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index 0401ea3..266473d 100644 (file)
--- 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.87;
+$VERSION = 0.88;
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
@@ -563,6 +563,7 @@ sub new {
     $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
     $self->{'ambient_hints'} = 0;
     $self->{'ambient_hinthash'} = undef;
+    $self->{'inlined_constants'} = $self->scan_for_constants;
     $self->init();
 
     while (my $arg = shift @_) {
@@ -599,6 +600,25 @@ sub new {
     }
 }
 
+sub scan_for_constants {
+    my ($self) = @_;
+    my %ret;
+
+    B::walksymtable(\%::, sub {
+        my ($gv) = @_;
+
+        my $cv = $gv->CV;
+        return if !$cv || class($cv) ne 'CV';
+
+        my $const = $cv->const_sv;
+        return if !$const || class($const) eq 'SPECIAL';
+
+        $ret{ 0 + $const->object_2svref } = $gv->NAME;
+    }, sub { 1 });
+
+    return \%ret;
+}
+
 # Initialise the contextual information, either from
 # defaults provided with the ambient_pragmas method,
 # or from perl's own defaults otherwise.
@@ -3628,6 +3648,8 @@ sub const {
        return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
     } elsif (class($sv) eq "NULL") {
        return 'undef';
+    } elsif (my $const = $self->{'inlined_constants'}->{ 0 + $sv->object_2svref }) {
+        return $const;
     }
     # convert a version object into the "v1.2.3" string in its V magic
     if ($sv->FLAGS & SVs_RMG) {

diff --git a/ext/B/t/deparse.t b/ext/B/t/deparse.t
index c9232a2..50abd35 100644 (file)
--- a/ext/B/t/deparse.t
+++ b/ext/B/t/deparse.t
@@ -27,7 +27,7 @@ BEGIN {
     require feature;
     feature->import(':5.10');
 }
-use Test::More tests => 68;
+use Test::More tests => 74;
 
 use B::Deparse;
 my $deparse = B::Deparse->new();
@@ -147,10 +147,18 @@ sub getcode {
    return $deparser->coderef2text(shift);
 }
 
+package Moo;
+use overload '0+' => sub { 42 };
+
 package main;
 use strict;
 use warnings;
 use constant GLIPP => 'glipp';
+use constant PI => 4;
+use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
+use Fcntl qw/O_NONBLOCK O_SYNC O_EXCL/;
+BEGIN { delete $::Fcntl::{O_SYNC}; }
+use POSIX qw/O_CREAT/;
 sub test {
    my $val = shift;
    my $res = B::Deparse::Wrapper::getcode($val);
@@ -422,15 +430,15 @@ else { x(); }
 my($y, $t);
 /x${y}z$t/;
 ####
-# SKIP ?$B::Deparse::VERSION <= 0.87 && "TODO new undocumented cpan-bug #33708"
+# SKIP ?$B::Deparse::VERSION <= 0.88 && "TODO new undocumented cpan-bug #33708"
 # 55  (cpan-bug #33708)
 %{$_ || {}}
 ####
-# SKIP ?$B::Deparse::VERSION <= 0.87 && "TODO hash constants not yet fixed"
+# SKIP ?$B::Deparse::VERSION <= 0.88 && "TODO hash constants not yet fixed"
 # 56  (cpan-bug #33708)
 use constant H => { "#" => 1 }; H->{"#"}
 ####
-# SKIP ?$B::Deparse::VERSION <= 0.87 && "TODO optimized away 0 not yet fixed"
+# SKIP ?$B::Deparse::VERSION <= 0.88 && "TODO optimized away 0 not yet fixed"
 # 57  (cpan-bug #33708)
 foreach my $i (@_) { 0 }
 ####
@@ -548,5 +556,25 @@ if (do { $a++; GLIPP }) { x() }
 >>>>
 x() if $a;
 if ($a == 1) { x(); } elsif ($b == 2) { z(); }
-if (do { foo(); 'glipp' }) { x(); }
-if (do { ++$a; 'glipp' }) { x(); }
+if (do { foo(); GLIPP }) { x(); }
+if (do { ++$a; GLIPP }) { x(); }
+####
+# 62 tests for deparsing constants
+warn PI;
+####
+# 63 tests for deparsing imported constants
+warn O_NONBLOCK;
+####
+# 64 tests for deparsing re-exported constants
+warn O_CREAT;
+####
+# 65 tests for deparsing imported constants that got deleted from the original namespace
+warn O_SYNC;
+####
+# 66 tests for deparsing constants which got turned into full typeglobs
+warn O_EXCL;
+eval '@Fcntl::O_EXCL = qw/affe tiger/;';
+warn O_EXCL;
+####
+# 67 tests for deparsing of blessed constant with overloaded numification
+warn OVERLOADED_NUMIFICATION;

diff --git a/pod/perltodo.pod b/pod/perltodo.pod
index 77e2c8f..71aa49d 100644 (file)
--- a/pod/perltodo.pod
+++ b/pod/perltodo.pod
@@ -126,28 +126,6 @@ tests that are currently missing.
 
 A full test suite for the B module would be nice.
 
-=head2 Deparse inlined constants
-
-Code such as this
-
-    use constant PI => 4;
-    warn PI
-
-will currently deparse as
-
-    use constant ('PI', 4);
-    warn 4;
-
-because the tokenizer inlines the value of the constant subroutine C<PI>.
-This allows various compile time optimisations, such as constant folding
-and dead code elimination. Where these haven't happened (such as the example
-above) it ought be possible to make B::Deparse work out the name of the
-original constant, because just enough information survives in the symbol
-table to do this. Specifically, the same scalar is used for the constant in
-the optree as is used for the constant subroutine, so by iterating over all
-symbol tables and generating a mapping of SV address to constant name, it
-would be possible to provide B::Deparse with this functionality.
-
 =head2 A decent benchmark
 
 C<perlbench> seems impervious to any recent changes made to the perl core. It