Change 19939 by [EMAIL PROTECTED] on 2003/07/02 20:10:47
Subject: [PATCH] various Deparse fixes
From: Dave Mitchell <[EMAIL PROTECTED]>
Date: Wed, 2 Jul 2003 18:10:45 +0100
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/ext/B/B/Concise.pm#23 edit
... //depot/perl/ext/B/B/Debug.pm#22 edit
... //depot/perl/ext/B/B/Deparse.pm#133 edit
... //depot/perl/ext/B/defsubs_h.PL#17 edit
... //depot/perl/t/TEST#85 edit
... //depot/perl/t/op/ord.t#13 edit
Differences ...
==== //depot/perl/ext/B/B/Concise.pm#23 (text) ====
Index: perl/ext/B/B/Concise.pm
--- perl/ext/B/B/Concise.pm#22~19610~ Fri May 23 23:42:52 2003
+++ perl/ext/B/B/Concise.pm Wed Jul 2 13:10:47 2003
@@ -14,7 +14,7 @@
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 @@
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};
}
==== //depot/perl/ext/B/B/Debug.pm#22 (text) ====
Index: perl/ext/B/B/Debug.pm
--- perl/ext/B/B/Debug.pm#21~19916~ Tue Jul 1 09:51:31 2003
+++ perl/ext/B/B/Debug.pm Wed Jul 2 13:10:47 2003
@@ -73,7 +73,7 @@
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
==== //depot/perl/ext/B/B/Deparse.pm#133 (text) ====
Index: perl/ext/B/B/Deparse.pm
--- perl/ext/B/B/Deparse.pm#132~19665~ Mon Jun 2 11:22:06 2003
+++ perl/ext/B/B/Deparse.pm Wed Jul 2 13:10:47 2003
@@ -15,7 +15,7 @@
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 @@
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 @@
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 @@
{
# 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 @@
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 @@
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
==== //depot/perl/ext/B/defsubs_h.PL#17 (text) ====
Index: perl/ext/B/defsubs_h.PL
--- perl/ext/B/defsubs_h.PL#16~19916~ Tue Jul 1 09:51:31 2003
+++ perl/ext/B/defsubs_h.PL Wed Jul 2 13:10:47 2003
@@ -18,9 +18,11 @@
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);
==== //depot/perl/t/TEST#85 (xtext) ====
Index: perl/t/TEST
--- perl/t/TEST#84~16910~ Thu May 30 18:10:08 2002
+++ perl/t/TEST Wed Jul 2 13:10:47 2003
@@ -228,7 +228,7 @@
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 |";
==== //depot/perl/t/op/ord.t#13 (xtext) ====
Index: perl/t/op/ord.t
--- perl/t/op/ord.t#12~13740~ Mon Dec 17 11:11:29 2001
+++ perl/t/op/ord.t Wed Jul 2 13:10:47 2003
@@ -2,7 +2,7 @@
BEGIN {
chdir 't' if -d 't';
- @INC = qw(.);
+ @INC = qw(. ../lib); # ../lib needed for test.deparse
require "test.pl";
}
End of Patch.
