From 127212b23933541d95e57814dfd91e6456b50ddd Mon Sep 17 00:00:00 2001 From: Dave Mitchell Date: Wed, 2 Jul 2003 19:10:45 +0100 Subject: [PATCH] various Deparse fixes Message-ID: <20030702171045.GF2137@fdgroup.com> p4raw-id: //depot/perl@19939 --- ext/B/B/Concise.pm | 19 ++++++++++++++----- ext/B/B/Debug.pm | 2 +- ext/B/B/Deparse.pm | 37 ++++++++++++++++++++++++++++++++----- ext/B/defsubs_h.PL | 6 ++++-- t/TEST | 2 +- t/op/ord.t | 2 +- 6 files changed, 53 insertions(+), 15 deletions(-) diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 3611626..5014cc9 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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"; } -- 2.7.4