various Deparse fixes

Message-ID: <20030702171045.GF2137@fdgroup.com>

p4raw-id: //depot/perl@19939

diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 3611626..5014cc9 100644 (file)
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -14,7 +14,7 @@ our @EXPORT_OK = qw(set_style set_style_standard add_callback
                    concise_cv concise_main);
 
 use B qw(class ppname main_start main_root main_cv cstring svref_2object
-        SVf_IOK SVf_NOK SVf_POK SVf_IVisUV OPf_KIDS);
+        SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS CVf_ANON);
 
 my %style = 
   ("terse" =>
@@ -436,10 +436,19 @@ sub concise_op {
        my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
        if (defined $padname and class($padname) ne "SPECIAL") {
            $h{targarg}  = $padname->PVX;
-           my $intro = $padname->NVX - $cop_seq_base;
-           my $finish = int($padname->IVX) - $cop_seq_base;
-           $finish = "end" if $finish == 999999999 - $cop_seq_base;
-           $h{targarglife} = "$h{targarg}:$intro,$finish";
+           if ($padname->FLAGS & SVf_FAKE) {
+               my $fake = '';
+               $fake .= 'a' if $padname->IVX & 1; # PAD_FAKELEX_ANON
+               $fake .= 'm' if $padname->IVX & 2; # PAD_FAKELEX_MULTI
+               $fake .= ':' . $padname->NVX if $curcv->CvFLAGS & CVf_ANON;
+               $h{targarglife} = "$h{targarg}:FAKE:$fake";
+           }
+           else {
+               my $intro = $padname->NVX - $cop_seq_base;
+               my $finish = int($padname->IVX) - $cop_seq_base;
+               $finish = "end" if $finish == 999999999 - $cop_seq_base;
+               $h{targarglife} = "$h{targarg}:$intro,$finish";
+           }
        } else {
            $h{targarglife} = $h{targarg} = "t" . $h{targ};
        }

diff --git a/ext/B/B/Debug.pm b/ext/B/B/Debug.pm
index 684e6b2..38cfc67 100644 (file)
--- a/ext/B/B/Debug.pm
+++ b/ext/B/B/Debug.pm
@@ -73,7 +73,7 @@ sub B::COP::debug {
     my ($op) = @_;
     $op->B::OP::debug();
     my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
-    printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
+    printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
        cop_label       %s
        cop_stashpv     %s
        cop_file        %s

diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index 3af74bc..6829d92 100644 (file)
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -15,7 +15,7 @@ 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 SVf_FAKE
+        SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG
          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);
@@ -289,7 +289,17 @@ sub next_todo {
            my $file = $gv->FILE;
            $l = "\n\f#line $line \"$file\"\n";
        }
-        return "${l}sub $name " . $self->deparse_sub($cv);
+       my $p = '';
+       if (class($cv->STASH) ne "SPECIAL") {
+           my $stash = $cv->STASH->NAME;
+           if ($stash ne $self->{'curstash'}) {
+               $p = "package $stash;\n";
+               $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
+               $self->{'curstash'} = $stash;
+           }
+           $name =~ s/^\Q$stash\E:://;
+       }
+        return "${p}${l}sub $name " . $self->deparse_sub($cv);
     }
 }
 
@@ -585,6 +595,8 @@ sub compile {
        my $laststash = defined $self->{'curcop'}
            ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
        if (defined *{$laststash."::DATA"}{IO}) {
+           print "package $laststash;\n"
+               unless $laststash eq $self->{'curstash'};
            print "__DATA__\n";
            print readline(*{$laststash."::DATA"});
        }
@@ -1603,7 +1615,7 @@ sub pp_refgen {
             {
                 # The @a in \(@a) isn't in ref context, but only when the
                 # parens are there.
-                return "\\(" . $self->deparse($kid->sibling, 1) . ")";
+               return "\\(" . $self->pp_list($op->first) . ")";
             } elsif ($sib_name eq 'entersub') {
                 my $text = $self->deparse($kid->sibling, 1);
                 # Always show parens for \(&func()), but only with -p otherwise
@@ -2596,7 +2608,14 @@ sub pp_rv2av {
     my $kid = $op->first;
     if ($kid->name eq "const") { # constant list
        my $av = $self->const_sv($kid);
-       return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
+       my @a = map const($_), $av->ARRAY;
+       if ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
+           # collapse (-1,0,1,2) into (-1..2)
+           my ($s, $e) = @a[0,-1];
+           my $i = $s;
+           return "($s..$e)" unless grep $i++ != $_, @a;
+       }
+       return "(" . join(", ", @a) . ")";
     } else {
        return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
     }
@@ -3195,7 +3214,15 @@ sub const {
        return ('undef', '1', '(!1)')[$$sv-1]; # sv_undef, sv_yes, sv_no
     } elsif (class($sv) eq "NULL") {
        return 'undef';
-    } elsif ($sv->FLAGS & SVf_IOK) {
+    }
+    # convert a version object into the "v1.2.3" string in its V magic
+    if ($sv->FLAGS & SVs_RMG) {
+       for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
+           return $mg->PTR if $mg->TYPE eq 'V';
+       }
+    }
+
+    if ($sv->FLAGS & SVf_IOK) {
        return $sv->int_value;
     } elsif ($sv->FLAGS & SVf_NOK) {
        # try the default stringification

diff --git a/ext/B/defsubs_h.PL b/ext/B/defsubs_h.PL
index 8a10bf4..81c1b49 100644 (file)
--- a/ext/B/defsubs_h.PL
+++ b/ext/B/defsubs_h.PL
@@ -18,9 +18,11 @@ foreach my $const (qw(
                      SVf_READONLY SVTYPEMASK
                      GVf_IMPORTED_AV GVf_IMPORTED_HV
                      GVf_IMPORTED_SV GVf_IMPORTED_CV
-                     CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_CONST CVf_ASSERTION
+                     CVf_CLONE CVf_CLONED CVf_ANON CVf_OLDSTYLE
+                     CVf_UNIQUE CVf_NODEBUG CVf_METHOD CVf_LOCKED
+                     CVf_LVALUE CVf_CONST CVf_WEAKOUTSIDE CVf_ASSERTION
                       SVpad_OUR SVf_FAKE SVf_IOK SVf_IVisUV SVf_NOK SVf_POK 
-                     SVf_ROK SVp_IOK SVp_POK SVp_NOK SVt_PVGV SVt_PVHV
+                     SVf_ROK SVp_IOK SVp_POK SVp_NOK SVt_PVGV SVt_PVHV SVs_RMG
                      ))
  {
   doconst($const);

diff --git a/t/TEST b/t/TEST
index f2f623d..92a9d8f 100755 (executable)
--- a/t/TEST
+++ b/t/TEST
@@ -228,7 +228,7 @@ EOT
        my $testswitch = '-I. -MTestInit'; # -T will strict . from @INC
        if ($type eq 'deparse') {
            my $deparse =
-               "./perl $testswitch $switch -I../lib -MO=-qq,Deparse,".
+               "./perl $testswitch $switch -I../lib -MO=-qq,Deparse,-sv1.,".
                "-l$deparse_opts$file_opts ".
                "$test > $test.dp ".
                "&& ./perl $testswitch $switch -I../lib $test.dp |";

diff --git a/t/op/ord.t b/t/op/ord.t
index ff51c18..4556664 100755 (executable)
--- a/t/op/ord.t
+++ b/t/op/ord.t
@@ -2,7 +2,7 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    @INC = qw(.);
+    @INC = qw(. ../lib); # ../lib needed for test.deparse
     require "test.pl";
 }