B::Concise updates (incl. avoiding use of op_seq)

[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 5a61a6d..37b98a0 100644 (file)
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -8,14 +8,14 @@
 
 package B::Deparse;
 use Carp;
-use B qw(class main_root main_start main_cv svref_2object opnumber cstring
+use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
         OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
         OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
         OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
         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_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE
          CVf_METHOD CVf_LOCKED CVf_LVALUE
         PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
         PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
@@ -542,20 +542,21 @@ sub compile {
        my $self = B::Deparse->new(@args);
        # First deparse command-line args
        if (defined $^I) { # deparse -i
-           print q(BEGIN { $^I = ).cstring($^I).qq(; }\n);
+           print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
        }
        if ($^W) { # deparse -w
            print qq(BEGIN { \$^W = $^W; }\n);
        }
        if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
-           my $fs = cstring($/) || 'undef';
-           my $bs = cstring($O::savebackslash) || 'undef';
+           my $fs = perlstring($/) || 'undef';
+           my $bs = perlstring($O::savebackslash) || 'undef';
            print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
        }
        my @BEGINs  = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
+       my @CHECKs  = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
        my @INITs   = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
        my @ENDs    = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
-       for my $block (@BEGINs, @INITs, @ENDs) {
+       for my $block (@BEGINs, @CHECKs, @INITs, @ENDs) {
            $self->todo($block, 0);
        }
        $self->stash_subs();
@@ -586,7 +587,7 @@ sub compile {
 sub coderef2text {
     my $self = shift;
     my $sub = shift;
-    croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
+    croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
 
     $self->init();
     return $self->indent($self->deparse_sub(svref_2object($sub)));
@@ -1080,7 +1081,8 @@ sub gv_name {
 Carp::confess() if $gv->isa("B::CV");
     my $stash = $gv->STASH->NAME;
     my $name = $gv->SAFENAME;
-    if ($stash eq $self->{'curstash'} or $globalnames{$name}
+    if (($stash eq 'main' && $globalnames{$name})
+       or ($stash eq $self->{'curstash'} && !$globalnames{$name})
        or $name =~ /^[^A-Za-z_]/)
     {
        $stash = "";
@@ -1128,7 +1130,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) {
@@ -1139,8 +1144,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];
        }
@@ -1265,7 +1272,7 @@ sub declare_warnings {
     elsif (($to & WARN_MASK) eq "\0"x length($to)) {
        return "no warnings;\n";
     }
-    return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
+    return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
 }
 
 sub declare_hints {
@@ -1950,6 +1957,7 @@ sub logop {
 
 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
 sub pp_or  { logop(@_, "or",  2, "||", 10, "unless") }
+sub pp_dor { logop(@_, "err", 2, "//", 10, "") }
 
 # xor is syntactically a logop, but it's really a binop (contrary to
 # old versions of opcode.pl). Syntax is what matters here.
@@ -1966,7 +1974,8 @@ sub logassignop {
 }
 
 sub pp_andassign { logassignop(@_, "&&=") }
-sub pp_orassign { logassignop(@_, "||=") }
+sub pp_orassign  { logassignop(@_, "||=") }
+sub pp_dorassign { logassignop(@_, "//=") }
 
 sub listop {
     my $self = shift;
@@ -2414,7 +2423,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;
@@ -2437,7 +2446,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
@@ -3009,7 +3023,7 @@ sub re_uninterp {
           | \\[uUlLQE]
           )
 
-       /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
+       /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
 
     return $str;
 }
@@ -3037,7 +3051,7 @@ sub re_uninterp_extended {
           | \\[uUlLQE]
           )
 
-       /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
+       /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
 
     return $str;
 }
@@ -3731,7 +3745,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);   
        }