Fix bug #22216 : B::Deparse can't handle "use Module Version"

[p5sagit/p5-mst-13.2.git] / ext / B / B / Deparse.pm

diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index 8d976af..06d795a 100644 (file)
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -15,8 +15,8 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
         OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
         OPpSORT_REVERSE
-        SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR
-         CVf_METHOD CVf_LOCKED CVf_LVALUE
+        SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE
+         CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION
         PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
         PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
 $VERSION = 0.63;
@@ -326,7 +326,14 @@ sub begin_is_use {
 
        return unless $self->const_sv($constop)->PV eq $module;
        $constop = $constop->sibling;
-       $version = $self->const_sv($constop)->int_value;
+       $version = $self->const_sv($constop);
+       if (class($version) ne "PVMG") {
+           # version is either an integer or a double
+           $version = $version->PV;
+       } else {
+           # version specified as a v-string
+           $version = 'v'.join '.', map ord, split //, $version->PV;
+       }
        $constop = $constop->sibling;
        return if $constop->name ne "method_named";
        return if $self->const_sv($constop)->PV ne "VERSION";
@@ -748,11 +755,12 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
     if ($cv->FLAGS & SVf_POK) {
        $proto = "(". $cv->PV . ") ";
     }
-    if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
+    if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)) {
         $proto .= ": ";
         $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
         $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
         $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
+        $proto .= "assertion " if $cv->CvFLAGS & CVf_ASSERTION;
     }
 
     local($self->{'curcv'}) = $cv;
@@ -1130,7 +1138,10 @@ sub lex_in_scope {
 sub populate_curcvlex {
     my $self = shift;
     for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
-       my @padlist = $cv->PADLIST->ARRAY;
+       my $padlist = $cv->PADLIST;
+       # an undef CV still in lexical chain
+       next if class($padlist) eq "SPECIAL";
+       my @padlist = $padlist->ARRAY;
        my @ns = $padlist[0]->ARRAY;
 
        for (my $i=0; $i<@ns; ++$i) {
@@ -1141,8 +1152,10 @@ sub populate_curcvlex {
                next;
            }
             my $name = $ns[$i]->PVX;
-           my $seq_st = $ns[$i]->NVX;
-           my $seq_en = int($ns[$i]->IVX);
+           my ($seq_st, $seq_en) =
+               ($ns[$i]->FLAGS & SVf_FAKE)
+                   ? (0, 999999)
+                   : ($ns[$i]->NVX, $ns[$i]->IVX);
 
            push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
        }
@@ -2418,7 +2431,7 @@ BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
 
 sub pp_null {
     my $self = shift;
-    my($op, $cx) = @_;
+    my($op, $cx, $flags) = @_;
     if (class($op) eq "OP") {
        # old value is lost
        return $self->{'ex_const'} if $op->targ == OP_CONST;
@@ -2441,7 +2454,12 @@ sub pp_null {
                                   . $self->deparse($op->first->sibling, 20),
                                   $cx, 20);
     } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) {
-       return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
+       if ($flags) {
+           return $self->deparse($op->first, $cx);
+       }
+       else {
+           return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
+       }
     } elsif (!null($op->first->sibling) and
             $op->first->sibling->name eq "null" and
             class($op->first->sibling) eq "UNOP" and
@@ -3173,7 +3191,7 @@ sub single_delim {
 sub const {
     my $sv = shift;
     if (class($sv) eq "SPECIAL") {
-       return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
+       return ('undef', '1', '(!1)')[$$sv-1]; # sv_undef, sv_yes, sv_no
     } elsif (class($sv) eq "NULL") {
        return 'undef';
     } elsif ($sv->FLAGS & SVf_IOK) {
@@ -3235,10 +3253,10 @@ sub dq {
        my $first = $self->dq($op->first);
        my $last  = $self->dq($op->last);
 
-       # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
+       # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
        ($last =~ /^[A-Z\\\^\[\]_?]/ &&
            $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
-           || ($last =~ /^[{\[\w_]/ &&
+           || ($last =~ /^[:'{\[\w_]/ &&
                $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
 
        return $first . $last;
@@ -3735,7 +3753,7 @@ sub pp_subst {
            $flags .= "e";
        }
        if ($op->pmflags & PMf_EVAL) {
-           $repl = $self->deparse($repl, 0);
+           $repl = $self->deparse($repl, 0, 1);
        } else {
            $repl = $self->dq($repl);   
        }