Once again syncing after too long an absence
[p5sagit/p5-mst-13.2.git] / ext / B / B / Deparse.pm
index 5c5c5eb..b0a5eae 100644 (file)
@@ -17,7 +17,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber
          CVf_METHOD CVf_LOCKED CVf_LVALUE
         PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
         PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = 0.591;
+$VERSION = 0.60;
 use strict;
 
 # Changes between 0.50 and 0.51:
@@ -83,6 +83,12 @@ use strict;
 # - added support for Chip's OP_METHOD_NAMED
 # - added support for Ilya's OPpTARGET_MY optimization
 # - elided arrows before `()' subscripts when possible
+# Changes between 0.59 and 0.60
+# - support for method attribues was added
+# - some warnings fixed
+# - separate recognition of constant subs
+# - rewrote continue block handling, now recoginizing for loops
+# - added more control of expanding control structures
 
 # Todo:
 # - finish tr/// changes
@@ -93,8 +99,8 @@ use strict;
 # - left/right context
 # - recognize `use utf8', `use integer', etc
 # - treat top-level block specially for incremental output
-# - interpret in high bit chars in string as utf8 \x{...} (when?)
-# - copy comments (look at real text with $^P?) 
+# - interpret high bit chars in string as utf8 \x{...} (when?)
+# - copy comments (look at real text with $^P?)
 # - avoid semis in one-statement blocks
 # - associativity of &&=, ||=, ?:
 # - ',' => '=>' (auto-unquote?)
@@ -108,7 +114,6 @@ use strict;
 # - version using op_next instead of op_first/sibling?
 # - avoid string copies (pass arrays, one big join?)
 # - auto-apply `-u'?
-# - while{} with one-statement continue => for(; XXX; XXX) {}?
 # - -uPackage:: descend recursively?
 # - here-docs?
 # - <DATA>?
@@ -357,6 +362,8 @@ sub new {
            $self->{'unquote'} = 1;
        } elsif (substr($arg, 0, 2) eq "-s") {
            $self->style_opts(substr $arg, 2);
+       } elsif ($arg =~ /^-x(\d)$/) {
+           $self->{'expand'} = $1;
        }
     }
     return $self;
@@ -393,6 +400,7 @@ sub deparse {
     my $self = shift;
     my($op, $cx) = @_;
 #    cluck if class($op) eq "NULL";
+#    cluck unless $op;
 #    return $self->$ {\("pp_" . $op->name)}($op, $cx);
     my $meth = "pp_" . $op->name;
     return $self->$meth($op, $cx);
@@ -446,6 +454,11 @@ sub deparse_sub {
        # skip leavesub
        return $proto . "{\n\t" . 
            $self->deparse($cv->ROOT->first, 0) . "\n\b}\n"; 
+    }
+    my $sv = $cv->const_sv;
+    if ($$sv) {
+       # uh-oh. inlinable sub... format it differently
+       return $proto . "{ " . const($sv) . " }\n";
     } else { # XSUB?
        return $proto  . "{}\n";
     }
@@ -679,70 +692,69 @@ sub pp_entertry { # see also leavetry
     return "XXX";
 }
 
-# leave and scope/lineseq should probably share code
-sub pp_leave {
+sub lineseq {
     my $self = shift;
-    my($op, $cx) = @_;
-    my ($kid, $expr);
-    my @exprs;
-    local($self->{'curstash'}) = $self->{'curstash'};
-    $kid = $op->first->sibling; # skip enter
-    if (is_miniwhile($kid)) {
-       my $top = $kid->first;
-       my $name = $top->name;
-       if ($name eq "and") {
-           $name = "while";
-       } elsif ($name eq "or") {
-           $name = "until";
-       } else { # no conditional -> while 1 or until 0
-           return $self->deparse($top->first, 1) . " while 1";
-       }
-       my $cond = $top->first;
-       my $body = $cond->sibling->first; # skip lineseq
-       $cond = $self->deparse($cond, 1);
-       $body = $self->deparse($body, 1);
-       return "$body $name $cond";
-    }
-    for (; !null($kid); $kid = $kid->sibling) {
+    my(@ops) = @_;
+    my($expr, @exprs);
+    for (my $i = 0; $i < @ops; $i++) {
        $expr = "";
-       if (is_state $kid) {
-           $expr = $self->deparse($kid, 0);
-           $kid = $kid->sibling;
-           last if null $kid;
+       if (is_state $ops[$i]) {
+           $expr = $self->deparse($ops[$i], 0);
+           $i++;
+           last if $i > $#ops;
        }
-       $expr .= $self->deparse($kid, 0);
+       if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
+           $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
+       {
+           push @exprs, $expr . $self->for_loop($ops[$i], 0);
+           $i++;
+           next;
+       }
+       $expr .= $self->deparse($ops[$i], 0);
        push @exprs, $expr if length $expr;
     }
-    if ($cx > 0) { # inside an expression
-       return "do { " . join(";\n", @exprs) . " }";
-    } else {
-       return join(";\n", @exprs) . ";";
-    }
+    return join(";\n", @exprs);
 }
 
-sub pp_scope {
-    my $self = shift;
-    my($op, $cx) = @_;
-    my ($kid, $expr);
-    my @exprs;
-    for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
-       $expr = "";
-       if (is_state $kid) {
-           $expr = $self->deparse($kid, 0);
-           $kid = $kid->sibling;
-           last if null $kid;
+sub scopeop {
+    my($real_block, $self, $op, $cx) = @_;
+    my $kid;
+    my @kids;
+    local($self->{'curstash'}) = $self->{'curstash'} if $real_block;
+    if ($real_block) {
+       $kid = $op->first->sibling; # skip enter
+       if (is_miniwhile($kid)) {
+           my $top = $kid->first;
+           my $name = $top->name;
+           if ($name eq "and") {
+               $name = "while";
+           } elsif ($name eq "or") {
+               $name = "until";
+           } else { # no conditional -> while 1 or until 0
+               return $self->deparse($top->first, 1) . " while 1";
+           }
+           my $cond = $top->first;
+           my $body = $cond->sibling->first; # skip lineseq
+           $cond = $self->deparse($cond, 1);
+           $body = $self->deparse($body, 1);
+           return "$body $name $cond";
        }
-       $expr .= $self->deparse($kid, 0);
-       push @exprs, $expr if length $expr;
+    } else {
+       $kid = $op->first;
+    }
+    for (; !null($kid); $kid = $kid->sibling) {
+       push @kids, $kid;
     }
     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
-       return "do { " . join(";\n", @exprs) . " }";
+       return "do { " . $self->lineseq(@kids) . " }";
     } else {
-       return join(";\n", @exprs) . ";";
+       return $self->lineseq(@kids) . ";";
     }
 }
 
-sub pp_lineseq { pp_scope(@_) }
+sub pp_scope { scopeop(0, @_); }
+sub pp_lineseq { scopeop(0, @_); }
+sub pp_leave { scopeop(1, @_); }
 
 # The BEGIN {} is used here because otherwise this code isn't executed
 # when you run B::Deparse on itself.
@@ -1380,11 +1392,14 @@ sub logop {
     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
     my $left = $op->first;
     my $right = $op->first->sibling;
-    if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
+    if ($cx == 0 and is_scope($right) and $blockname
+       and $self->{'expand'} < 7)
+    { # if ($a) {$b}
        $left = $self->deparse($left, 1);
        $right = $self->deparse($right, 0);
        return "$blockname ($left) {\n\t$right\n\b}\cK";
-    } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
+    } elsif ($cx == 0 and $blockname and not $self->{'parens'}
+            and $self->{'expand'} < 7) { # $b if $a
        $right = $self->deparse($right, 1);
        $left = $self->deparse($left, 1);
        return "$right $blockname $left";
@@ -1675,7 +1690,8 @@ sub pp_cond_expr {
     my $false = $true->sibling;
     my $cuddle = $self->{'cuddle'};
     unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
-           (is_scope($false) || is_ifelse_cont($false))) {
+           (is_scope($false) || is_ifelse_cont($false))
+           and $self->{'expand'} < 7) {
        $cond = $self->deparse($cond, 8);
        $true = $self->deparse($true, 8);
        $false = $self->deparse($false, 8);
@@ -1704,20 +1720,24 @@ sub pp_cond_expr {
     return $head . join($cuddle, "", @elsifs) . $false; 
 }
 
-sub pp_leaveloop {
+sub loop_common {
     my $self = shift;
-    my($op, $cx) = @_;
+    my($op, $cx, $init) = @_;
     my $enter = $op->first;
     my $kid = $enter->sibling;
     local($self->{'curstash'}) = $self->{'curstash'};
     my $head = "";
     my $bare = 0;
+    my $body;
+    my $cond = undef;
     if ($kid->name eq "lineseq") { # bare or infinite loop 
        if (is_state $kid->last) { # infinite
            $head = "for (;;) "; # shorter than while (1)
+           $cond = "";
        } else {
            $bare = 1;
        }
+       $body = $kid;
     } elsif ($enter->name eq "enteriter") { # foreach
        my $ary = $enter->first->sibling; # first was pushmark
        my $var = $ary->sibling;
@@ -1749,62 +1769,60 @@ sub pp_leaveloop {
            $var = "\$" . $self->deparse($var, 1);
        }
        $head = "foreach $var ($ary) ";
-       $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
+       $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
     } elsif ($kid->name eq "null") { # while/until
        $kid = $kid->first;
-       my $name = {"and" => "while", "or" => "until"}
-                   ->{$kid->name};
-       $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
-       $kid = $kid->first->sibling;
+       my $name = {"and" => "while", "or" => "until"}->{$kid->name};
+       $cond = $self->deparse($kid->first, 1);
+       $head = "$name ($cond) ";
+       $body = $kid->first->sibling;
     } elsif ($kid->name eq "stub") { # bare and empty
        return "{;}"; # {} could be a hashref
     }
-    # The third-to-last kid is the continue block if the pointer used
-    # by `next BLOCK' points to its first OP, which happens to be the
-    # the op_next of the head of the _previous_ statement. 
-    # Unless it's a bare loop, in which case it's last, since there's
-    # no unstack or extra nextstate.
-    # Except if the previous head isn't null but the first kid is
-    # (because it's a nulled out nextstate in a scope), in which
-    # case the head's next is advanced past the null but the nextop's
-    # isn't, so we need to try nextop->next.
-    my $precont;
-    my $cont = $kid->first;
-    if ($bare) {
-       while (!null($cont->sibling)) {
-           $precont = $cont;
-           $cont = $cont->sibling;
-       }       
-    } else {
-       while (!null($cont->sibling->sibling->sibling)) {
-           $precont = $cont;
-           $cont = $cont->sibling;
+    # If there isn't a continue block, then the next pointer for the loop
+    # will point to the unstack, which is kid's penultimate child, except
+    # in a bare loop, when it will point to the leaveloop. When neither of
+    # these conditions hold, then the third-to-last child in the continue
+    # block (or the last in a bare loop).
+    my $cont_start = $enter->nextop;
+    my $cont;
+    if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
+       if ($bare) {
+           $cont = $body->last;
+       } else {
+           $cont = $body->first;
+           while (!null($cont->sibling->sibling->sibling)) {
+               $cont = $cont->sibling;
+           }
+       }
+       my $state = $body->first;
+       my $cuddle = $self->{'cuddle'};
+       my @states;
+       for (; $$state != $$cont; $state = $state->sibling) {
+           push @states, $state;
+       }
+       $body = $self->lineseq(@states);
+       if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
+           $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
+           $cont = "\cK";
+       } else {
+           $cont = $cuddle . "continue {\n\t" .
+             $self->deparse($cont, 0) . "\n\b}\cK";
        }
-    }
-    if ($precont and $ {$precont->next} == $ {$enter->nextop}
-       || $ {$precont->next} == $ {$enter->nextop->next} )
-    {
-       my $state = $kid->first;
-       my $cuddle = $self->{'cuddle'};
-       my($expr, @exprs);
-       for (; $$state != $$cont; $state = $state->sibling) {
-          $expr = "";
-          if (is_state $state) {
-              $expr = $self->deparse($state, 0);
-              $state = $state->sibling;
-              last if null $state;
-          }
-          $expr .= $self->deparse($state, 0);
-          push @exprs, $expr if $expr;
-       }
-       $kid = join(";\n", @exprs);
-       $cont = $cuddle . "continue {\n\t" .
-        $self->deparse($cont, 0) . "\n\b}\cK";
     } else {
        $cont = "\cK";
-       $kid = $self->deparse($kid, 0);
+       $body = $self->deparse($body, 0);
     }
-    return $head . "{\n\t" . $kid . "\n\b}" . $cont;
+    return $head . "{\n\t" . $body . "\n\b}" . $cont;
+}
+
+sub pp_leaveloop { loop_common(@_, "") }
+
+sub for_loop {
+    my $self = shift;
+    my($op, $cx) = @_;
+    my $init = $self->deparse($op, 1);
+    return $self->loop_common($op->sibling, $cx, $init);
 }
 
 sub pp_leavetry {
@@ -2851,8 +2869,8 @@ B::Deparse - Perl compiler backend to produce perl code
 
 =head1 SYNOPSIS
 
-B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>]
-     I<prog.pl>
+B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
+        [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
 
 =head1 DESCRIPTION
 
@@ -2997,6 +3015,55 @@ file is compiled as a main program.
 
 =back
 
+=item B<-x>I<LEVEL>
+
+Expand conventional syntax constructions into equivalent ones that expose
+their internal operation. I<LEVEL> should be a digit, with higher values
+meaning more expansion. As with B<-q>, this actually involves turning off
+special cases in B::Deparse's normal operations.
+
+If I<LEVEL> is at least 3, for loops will be translated into equivalent
+while loops with continue blocks; for instance
+
+    for ($i = 0; $i < 10; ++$i) {
+        print $i;
+    }
+
+turns into
+
+    $i = 0;
+    while ($i < 10) {
+        print $i;
+    } continue {
+        ++$i
+    }
+
+Note that in a few cases this translation can't be perfectly carried back
+into the source code -- if the loop's initializer declares a my variable,
+for instance, it won't have the correct scope outside of the loop.
+
+If I<LEVEL> is at least 7, if statements will be translated into equivalent
+expressions using C<&&>, C<?:> and C<do {}>; for instance
+
+    print 'hi' if $nice;
+    if ($nice) {
+        print 'hi';
+    }
+    if ($nice) {
+        print 'hi';
+    } else {
+        print 'bye';
+    }
+
+turns into
+
+    $nice and print 'hi';
+    $nice and do { print 'hi' };
+    $nice ? do { print 'hi' } : do { print 'bye' };
+
+Long sequences of elsifs will turn into nested ternary operators, which
+B::Deparse doesn't know how to indent nicely.
+
 =back
 
 =head1 USING B::Deparse AS A MODULE
@@ -3043,7 +3110,7 @@ See the 'to do' list at the beginning of the module file.
 
 =head1 AUTHOR
 
-Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
+Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.