This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
deparse \&func() as \(&func()) for clarity
[perl5.git] / ext / B / B / Deparse.pm
index 91c08e7..5543a7b 100644 (file)
@@ -1,5 +1,5 @@
 # B::Deparse.pm
-# Copyright (c) 1998 Stephen McCamant. All rights reserved.
+# Copyright (c) 1998,1999 Stephen McCamant. All rights reserved.
 # This module is free software; you can redistribute and/or modify
 # it under the same terms as Perl itself.
 
@@ -8,8 +8,15 @@
 
 package B::Deparse;
 use Carp 'cluck';
-use B qw(class main_root main_start main_cv svref_2object);
-$VERSION = 0.53;
+use B qw(class main_root main_start main_cv svref_2object opnumber
+        OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
+        OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
+        OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
+        OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT
+        SVf_IOK SVf_NOK SVf_ROK SVf_POK
+        PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
+        PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
+$VERSION = 0.57;
 use strict;
 
 # Changes between 0.50 and 0.51:
@@ -26,16 +33,54 @@ use strict;
 # Changes between 0.51 and 0.52:
 # - added pp_threadsv (special variables under USE_THREADS)
 # - added documentation
-# Changes between 0.52 and 0.53
+# Changes between 0.52 and 0.53:
 # - many changes adding precedence contexts and associativity
 # - added `-p' and `-s' output style options
 # - various other minor fixes
+# Changes between 0.53 and 0.54:
+# - added support for new `for (1..100)' optimization,
+#   thanks to Gisle Aas
+# Changes between 0.54 and 0.55:
+# - added support for new qr// construct
+# - added support for new pp_regcreset OP
+# Changes between 0.55 and 0.56:
+# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
+# - fixed $# on non-lexicals broken in last big rewrite
+# - added temporary fix for change in opcode of OP_STRINGIFY
+# - fixed problem in 0.54's for() patch in `for (@ary)'
+# - fixed precedence in conditional of ?:
+# - tweaked list paren elimination in `my($x) = @_'
+# - made continue-block detection trickier wrt. null ops
+# - fixed various prototype problems in pp_entersub
+# - added support for sub prototypes that never get GVs
+# - added unquoting for special filehandle first arg in truncate
+# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
+# - added semicolons at the ends of blocks
+# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
+# Changes between 0.56 and 0.561:
+# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
+# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
+# Changes between 0.561 and 0.57:
+# - stylistic changes to symbolic constant stuff
+# - handled scope in s///e replacement code
+# - added unquote option for expanding "" into concats, etc.
+# - split method and proto parts of pp_entersub into separate functions
+# - various minor cleanups
 
 # Todo:
 # - {} around variables in strings ("${var}letters")
+#   base/lex.t 25-27
+#   comp/term.t 11
+# - left/right context
+# - recognize `use utf8', `use integer', etc
+# - handle swash-based utf8 tr/// (ick, looks hard)
+# - avoid semis in one-statement blocks
 # - associativity of &&=, ||=, ?:
 # - ',' => '=>' (auto-unquote?)
 # - break long lines ("\r" as discretionary break?)
+# - ANSI color syntax highlighting?
+# - include values of variables (e.g. set in BEGIN)
+# - coordinate with Data::Dumper (both directions? see previous)
 # - version using op_next instead of op_first/sibling?
 # - avoid string copies (pass arrays, one big join?)
 # - auto-apply `-u'?
@@ -44,6 +89,9 @@ use strict;
 # - here-docs?
 # - <DATA>?
 
+# Tests that will always fail:
+# comp/redef.t -- all (redefinition happens at compile time)
+
 # Object fields (were globals):
 #
 # avoid_local:
@@ -64,11 +112,16 @@ use strict;
 # array of [cop_seq, GV, is_format?] for subs and formats we still
 # want to deparse
 #
+# protos_todo:
+# as above, but [name, prototype] for subs that never got a GV
+#
 # subs_done, forms_done:
 # keys are addresses of GVs for subs and formats we've already
 # deparsed (or at least put into subs_todo)
 #
 # parens: -p
+# linenums: -l
+# unquote: -q
 # cuddle: ` ' or `\n', depending on -sC
 
 # A little explanation of how precedence contexts and associativity
@@ -77,7 +130,7 @@ use strict;
 # deparse() calls each per-op subroutine with an argument $cx (short
 # for context, but not the same as the cx* in the perl core), which is
 # a number describing the op's parents in terms of precedence, whether
-# they're inside and expression or at statement level, etc.  (see
+# they're inside an expression or at statement level, etc.  (see
 # chart below). When ops with children call deparse on them, they pass
 # along their precedence. Fractional values are used to implement
 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
@@ -120,6 +173,7 @@ use strict;
 # \n - newline and indent
 # \t - increase indent
 # \b - decrease indent (`outdent')
+# \f - flush left (no indent)
 # \cK - kill following semicolon, if any
 
 sub null {
@@ -152,8 +206,6 @@ sub next_todo {
     }
 }
 
-sub OPf_KIDS () { 4 }
-
 sub walk_tree {
     my($op, $sub) = @_;
     $sub->($op);
@@ -196,22 +248,47 @@ sub stash_subs {
     my $pack = shift;
     my(%stash, @ret);
     { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
+    if ($pack eq "main") {
+       $pack = "";
+    } else {
+       $pack = $pack . "::";
+    }
     my($key, $val);
     while (($key, $val) = each %stash) {
-       next unless class($val) eq "GV";
-       if (class($val->CV) ne "SPECIAL") {
-           next if $self->{'subs_done'}{$$val}++;
-           $self->todo($val, $val->CV, 0);
-           $self->walk_sub($val->CV);
-       }
-       if (class($val->FORM) ne "SPECIAL") {
-           next if $self->{'forms_done'}{$$val}++;
-           $self->todo($val, $val->FORM, 1);
-           $self->walk_sub($val->FORM);
+       my $class = class($val);
+       if ($class eq "PV") {
+           # Just a prototype
+           push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
+       } elsif ($class eq "IV") {
+           # Just a name
+           push @{$self->{'protos_todo'}}, [$pack . $key, undef];          
+       } elsif ($class eq "GV") {
+           if (class($val->CV) ne "SPECIAL") {
+               next if $self->{'subs_done'}{$$val}++;
+               $self->todo($val, $val->CV, 0);
+               $self->walk_sub($val->CV);
+           }
+           if (class($val->FORM) ne "SPECIAL") {
+               next if $self->{'forms_done'}{$$val}++;
+               $self->todo($val, $val->FORM, 1);
+               $self->walk_sub($val->FORM);
+           }
        }
     }
 }
 
+sub print_protos {
+    my $self = shift;
+    my $ar;
+    my @ret;
+    foreach $ar (@{$self->{'protos_todo'}}) {
+       my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
+       push @ret, "sub " . $ar->[0] .  "$proto;\n";
+    }
+    delete $self->{'protos_todo'};
+    return @ret;
+}
+
 sub style_opts {
     my $self = shift;
     my $opts = shift;
@@ -239,11 +316,16 @@ sub compile {
                $self->stash_subs(substr($arg, 2));
            } elsif ($arg eq "-p") {
                $self->{'parens'} = 1;
+           } elsif ($arg eq "-l") {
+               $self->{'linenums'} = 1;
+           } elsif ($arg eq "-q") {
+               $self->{'unquote'} = 1;
            } elsif (substr($arg, 0, 2) eq "-s") {
                $self->style_opts(substr $arg, 2);
            }
        }
        $self->walk_sub(main_cv, main_start);
+       print $self->print_protos;
        @{$self->{'subs_todo'}} =
            sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
        print indent($self->deparse(main_root, 0)), "\n" unless null main_root;
@@ -259,6 +341,7 @@ sub deparse {
     my $self = shift;
     my($op, $cx) = @_;
 #    cluck if class($op) eq "NULL";
+#    return $self->$ {\$op->ppaddr}($op, $cx);
     my $meth = $op->ppaddr;
     return $self->$meth($op, $cx);
 }
@@ -276,14 +359,16 @@ sub indent {
            $leader = substr($leader, 0, length($leader) - 4);
            $line = substr($line, 1);
        }
+       if (substr($line, 0, 1) eq "\f") {
+           $line = substr($line, 1); # no indent
+       } else {
+           $line = $leader . $line;
+       }
        $line =~ s/\cK;?//g;
-       $line = $leader . $line;
     }
     return join("\n", @lines);
 }
 
-sub SVf_POK () {0x40000}
-
 sub deparse_sub {
     my $self = shift;
     my $cv = shift;
@@ -326,16 +411,6 @@ sub deparse_format {
     return join("", @text) . ".";
 }
 
-# the aassign in-common check messes up SvCUR (always setting it
-# to a value >= 100), but it's probably safe to assume there
-# won't be any NULs in the names of my() variables. (with
-# stash variables, I wouldn't be so sure)
-sub padname_fix {
-    my $str = shift;
-    $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
-    return $str;
-}
-
 sub is_scope {
     my $op = shift;
     return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope"
@@ -366,7 +441,8 @@ sub is_scalar {
     return ($op->ppaddr eq "pp_rv2sv" or
            $op->ppaddr eq "pp_padsv" or
            $op->ppaddr eq "pp_gv" or # only in array/hash constructs
-           !null($op->first) && $op->first->ppaddr eq "pp_gvsv");
+           $op->flags & OPf_KIDS && !null($op->first)
+             && $op->first->ppaddr eq "pp_gvsv");
 }
 
 sub maybe_parens {
@@ -416,12 +492,10 @@ sub maybe_parens_func {
     }
 }
 
-sub OPp_LVAL_INTRO () { 128 }
-
 sub maybe_local {
     my $self = shift;
     my($op, $cx, $text) = @_;
-    if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
+    if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
        return $self->maybe_parens_func("local", $text, $cx, 16);
     } else {
        return $text;
@@ -437,7 +511,7 @@ sub padname_sv {
 sub maybe_my {
     my $self = shift;
     my($op, $cx, $text) = @_;
-    if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
+    if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
        return $self->maybe_parens_func("my", $text, $cx, 16);
     } else {
        return $text;
@@ -479,6 +553,11 @@ sub pp_regcmaybe { # see also regcomp
     return "XXX";
 }
 
+sub pp_regcreset { # see also regcomp
+    cluck "unexpected OP_REGCRESET";
+    return "XXX";
+}
+
 sub pp_substcont { # see also subst
     cluck "unexpected OP_SUBSTCONT";
     return "XXX";
@@ -561,7 +640,7 @@ sub pp_leave {
     if ($cx > 0) { # inside an expression
        return "do { " . join(";\n", @exprs) . " }";
     } else {
-       return join(";\n", @exprs);     
+       return join(";\n", @exprs) . ";";
     }
 }
 
@@ -583,7 +662,7 @@ sub pp_scope {
     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
        return "do { " . join(";\n", @exprs) . " }";
     } else {
-       return join(";\n", @exprs);     
+       return join(";\n", @exprs) . ";";
     }
 }
 
@@ -629,6 +708,10 @@ sub pp_nextstate {
        push @text, "package $stash;\n";
        $self->{'curstash'} = $stash;
     }
+    if ($self->{'linenums'}) {
+       push @text, "\f#line " . $op->line . 
+         ' "' . substr($op->filegv->NAME, 2), qq'"\n';
+    }
     return join("", @text);
 }
 
@@ -711,8 +794,6 @@ sub pp_not {
     }
 }
 
-sub OPf_SPECIAL () { 128 }
-
 sub unop {
     my $self = shift;
     my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
@@ -750,11 +831,6 @@ sub pp_abs { unop(@_, "abs") }
 sub pp_length { unop(@_, "length") }
 sub pp_ord { unop(@_, "ord") }
 sub pp_chr { unop(@_, "chr") }
-sub pp_ucfirst { unop(@_, "ucfirst") }
-sub pp_lcfirst { unop(@_, "lcfirst") }
-sub pp_uc { unop(@_, "uc") }
-sub pp_lc { unop(@_, "lc") }
-sub pp_quotemeta { unop(@_, "quotemeta") }
 
 sub pp_each { unop(@_, "each") }
 sub pp_values { unop(@_, "values") }
@@ -818,8 +894,6 @@ sub pp_exists {
                                    $cx, 16);
 }
 
-sub OPpSLICE () { 64 }
-
 sub pp_delete {
     my $self = shift;
     my($op, $cx) = @_;
@@ -835,13 +909,11 @@ sub pp_delete {
     }
 }
 
-sub OPp_CONST_BARE () { 64 }
-
 sub pp_require {
     my $self = shift;
     my($op, $cx) = @_;
     if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const"
-       and $op->first->private & OPp_CONST_BARE)
+       and $op->first->private & OPpCONST_BARE)
     {
        my $name = $op->first->sv->PV;
        $name =~ s[/][::]g;
@@ -870,8 +942,6 @@ sub padval {
     return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
 }
 
-sub OPf_REF () { 16 }
-
 sub pp_refgen {
     my $self = shift;  
     my($op, $cx) = @_;
@@ -892,13 +962,22 @@ sub pp_refgen {
                 $kid->sibling->ppaddr eq "pp_anoncode") {
            return "sub " .
                $self->deparse_sub($self->padval($kid->sibling->targ));
-       } elsif ($kid->ppaddr eq "pp_pushmark"
-                and $kid->sibling->ppaddr =~ /^pp_(pad|rv2)[ah]v$/
-                and not $kid->sibling->flags & OPf_REF) {
-           # The @a in \(@a) isn't in ref context, but only when the
-           # parens are there.
-           return "\\(" . $self->deparse($kid->sibling, 1) . ")";
-       }
+       } elsif ($kid->ppaddr eq "pp_pushmark") {
+            my $sib_ppaddr = $kid->sibling->ppaddr;
+            if ($sib_ppaddr =~ /^pp_(pad|rv2)[ah]v$/
+                and not $kid->sibling->flags & OPf_REF)
+            {
+                # The @a in \(@a) isn't in ref context, but only when the
+                # parens are there.
+                return "\\(" . $self->deparse($kid->sibling, 1) . ")";
+            } elsif ($kid->sibling->ppaddr eq 'pp_entersub') {
+                my $text = $self->deparse($kid->sibling, 1);
+                # Always show parens for \(&func()), but only with -p otherwise
+                $text = "($text)" if $self->{'parens'}
+                                 or $kid->sibling->private & OPpENTERSUB_AMPER;
+                return "\\$text";
+            }
+        }
     }
     $self->pfixop($op, $cx, "\\", 20);
 }
@@ -910,12 +989,30 @@ sub pp_readline {
     my($op, $cx) = @_;
     my $kid = $op->first;
     $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh>
-    if ($kid->ppaddr eq "pp_rv2gv") {
-       $kid = $kid->first;
-    }
     return "<" . $self->deparse($kid, 1) . ">";
 }
 
+# Unary operators that can occur as pseudo-listops inside double quotes
+sub dq_unop {
+    my $self = shift;
+    my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
+    my $kid;
+    if ($op->flags & OPf_KIDS) {
+       $kid = $op->first;
+       # If there's more than one kid, the first is an ex-pushmark.
+       $kid = $kid->sibling if not null $kid->sibling;
+       return $self->maybe_parens_unop($name, $kid, $cx);
+    } else {
+       return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");       
+    }
+}
+
+sub pp_ucfirst { dq_unop(@_, "ucfirst") }
+sub pp_lcfirst { dq_unop(@_, "lcfirst") }
+sub pp_uc { dq_unop(@_, "uc") }
+sub pp_lc { dq_unop(@_, "lc") }
+sub pp_quotemeta { dq_unop(@_, "quotemeta") }
+
 sub loopex {
     my $self = shift;
     my ($op, $cx, $name) = @_;
@@ -983,8 +1080,6 @@ sub pp_ftbinary { ftst(@_, "-B") }
 sub SWAP_CHILDREN () { 1 }
 sub ASSIGN () { 2 } # has OP= variant
 
-sub OPf_STACKED () { 64 }
-
 my(%left, %right);
 
 sub assoc_class {
@@ -1297,7 +1392,6 @@ sub pp_syswrite { listop(@_, "syswrite") }
 sub pp_send { listop(@_, "send") }
 sub pp_recv { listop(@_, "recv") }
 sub pp_seek { listop(@_, "seek") }
-sub pp_truncate { listop(@_, "truncate") }
 sub pp_fcntl { listop(@_, "fcntl") }
 sub pp_ioctl { listop(@_, "ioctl") }
 sub pp_flock { listop(@_, "flock") }
@@ -1357,6 +1451,32 @@ sub pp_glob {
     }
 }
 
+# Truncate is special because OPf_SPECIAL makes a bareword first arg
+# be a filehandle. This could probably be better fixed in the core
+# by moving the GV lookup into ck_truc.
+
+sub pp_truncate {
+    my $self = shift;
+    my($op, $cx) = @_;
+    my(@exprs);
+    my $parens = ($cx >= 5) || $self->{'parens'};
+    my $kid = $op->first->sibling;
+    my $fh;
+    if ($op->flags & OPf_SPECIAL) {
+       # $kid is an OP_CONST
+       $fh = $kid->sv->PV;
+    } else {
+       $fh = $self->deparse($kid, 6);
+        $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
+    }
+    my $len = $self->deparse($kid->sibling, 6);
+    if ($parens) {
+       return "truncate($fh, $len)";
+    } else {
+       return "truncate $fh, $len";
+    }
+}
+
 sub indirop {
     my $self = shift;
     my($op, $cx, $name) = @_;
@@ -1415,14 +1535,13 @@ sub pp_list {
     my($op, $cx) = @_;
     my($expr, @exprs);
     my $kid = $op->first->sibling; # skip pushmark
-    return $self->deparse($kid, $cx) if null $kid->sibling;
     my $lop;
     my $local = "either"; # could be local(...) or my(...)
     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
        # This assumes that no other private flags equal 128, and that
        # OPs that store things other than flags in their op_private,
        # like OP_AELEMFAST, won't be immediate children of a list.
-       unless ($lop->private & OPp_LVAL_INTRO or $lop->ppaddr eq "pp_undef")
+       unless ($lop->private & OPpLVAL_INTRO or $lop->ppaddr eq "pp_undef")
        {
            $local = ""; # or not
            last;
@@ -1436,6 +1555,7 @@ sub pp_list {
        }
     }
     $local = "" if $local eq "either"; # no point if it's all undefs
+    return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
     for (; !null($kid); $kid = $kid->sibling) {
        if ($local) {
            if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") {
@@ -1465,12 +1585,13 @@ sub pp_cond_expr {
     my $true = $cond->sibling;
     my $false = $true->sibling;
     my $cuddle = $self->{'cuddle'};
-    $cond = $self->deparse($cond, 1);
     unless ($cx == 0 and is_scope($true) and is_scope($false)) {
+       $cond = $self->deparse($cond, 8);
        $true = $self->deparse($true, 8);
        $false = $self->deparse($false, 8);
        return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
     } 
+    $cond = $self->deparse($cond, 1);
     $true = $self->deparse($true, 0);    
     if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif
        my $head = "if ($cond) {\n\t$true\n\b}";
@@ -1513,7 +1634,14 @@ sub pp_leaveloop {
     } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach
        my $ary = $enter->first->sibling; # first was pushmark
        my $var = $ary->sibling;
-       $ary = $self->deparse($ary, 1);
+       if ($enter->flags & OPf_STACKED
+           and not null $ary->first->sibling->sibling)
+       {
+           $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
+             $self->deparse($ary->first->sibling->sibling, 9);
+       } else {
+           $ary = $self->deparse($ary, 1);
+       }
        if (null $var) {
            if ($enter->flags & OPf_SPECIAL) { # thread special var
                $var = $self->pp_threadsv($enter, 1);
@@ -1549,38 +1677,42 @@ sub pp_leaveloop {
     # 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.
-    my($cont, $precont);
+    # 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) {
-       $cont = $kid->first;
        while (!null($cont->sibling)) {
            $precont = $cont;
            $cont = $cont->sibling;
        }       
     } else {
-       $cont = $kid->first;
        while (!null($cont->sibling->sibling->sibling)) {
            $precont = $cont;
            $cont = $cont->sibling;
        }
     }
-#    cluck $self->{'curcv'}->GV->NAME unless $precont;
-    if ($precont and $ {$precont->next} == $ {$enter->nextop}) {
-       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 $kid;
-           }
-           $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";
+    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 $kid;
+          }
+          $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);
@@ -1593,8 +1725,8 @@ sub pp_leavetry {
     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
 }
 
-sub OP_CONST () { 5 }
-sub OP_STRINGIFY () { 65 }
+BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
+BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
 
 sub pp_null {
     my $self = shift;
@@ -1624,6 +1756,16 @@ sub pp_null {
     }
 }
 
+# the aassign in-common check messes up SvCUR (always setting it
+# to a value >= 100), but it's probably safe to assume there
+# won't be any NULs in the names of my() variables. (with
+# stash variables, I wouldn't be so sure)
+sub padname_fix {
+    my $str = shift;
+    $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
+    return $str;
+}
+
 sub padname {
     my $self = shift;
     my $targ = shift;
@@ -1684,9 +1826,8 @@ sub rv2x {
     my $self = shift;
     my($op, $cx, $type) = @_;
     my $kid = $op->first;
-    my $scope = is_scope($kid);
-    $kid = $self->deparse($kid, 0);
-    return $type . ($scope ? "{$kid}" : $kid);
+    my $str = $self->deparse($kid, 0);
+    return $type . (is_scalar($kid) ? $str : "{$str}");
 }
 
 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
@@ -1700,7 +1841,8 @@ sub pp_av2arylen {
     if ($op->first->ppaddr eq "pp_padav") {
        return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
     } else {
-       return $self->maybe_local($op, $cx, $self->rv2x($op->first, '$#'));
+       return $self->maybe_local($op, $cx,
+                                 $self->rv2x($op->first, $cx, '$#'));
     }
 }
 
@@ -1809,48 +1951,146 @@ sub pp_lslice {
     return "($list)" . "[$idx]";
 }
 
-sub OPpENTERSUB_AMPER () { 8 }
-
-sub OPf_WANT () { 3 }
-sub OPf_WANT_VOID () { 1 }
-sub OPf_WANT_SCALAR () { 2 }
-sub OPf_WANT_LIST () { 2 }
-
 sub want_scalar {
     my $op = shift;
     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
 }
 
-sub pp_entersub {
+sub want_list {
+    my $op = shift;
+    return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
+}
+
+sub method {
     my $self = shift;
     my($op, $cx) = @_;
-    my $prefix = "";
-    my $amper = "";
-    my $proto = undef;
-    my $simple = 0;
-    my($kid, $args, @exprs);
-    if (not null $op->first->sibling) { # method
-       $kid = $op->first->sibling; # skip pushmark
-       my $obj = $self->deparse($kid, 24);
+    my $kid = $op->first->sibling; # skip pushmark
+    my($meth, $obj, @exprs);
+    if ($kid->ppaddr eq "pp_list" and want_list $kid) {
+       # When an indirect object isn't a bareword but the args are in
+       # parens, the parens aren't part of the method syntax (the LLAFR
+       # doesn't apply), but they make a list with OPf_PARENS set that
+       # doesn't get flattened by the append_elem that adds the method,
+       # making a (object, arg1, arg2, ...) list where the object
+       # usually is. This can be distinguished from 
+       # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
+       # object) because in the later the list is in scalar context
+       # as the left side of -> always is, while in the former
+       # the list is in list context as method arguments always are.
+       # (Good thing there aren't method prototypes!)
+       $meth = $kid->sibling->first;
+       $kid = $kid->first->sibling; # skip pushmark
+       $obj = $kid;
        $kid = $kid->sibling;
-       for (; not null $kid->sibling; $kid = $kid->sibling) {
+       for (; not null $kid; $kid = $kid->sibling) {
            push @exprs, $self->deparse($kid, 6);
        }
-       my $meth = $kid->first;
-       if ($meth->ppaddr eq "pp_const") {
-           $meth = $meth->sv->PV; # needs to be bare
-       } else {
-           $meth = $self->deparse($meth, 1);
+    } else {
+       $obj = $kid;
+       $kid = $kid->sibling;
+       for (; not null $kid->sibling; $kid = $kid->sibling) {
+           push @exprs, $self->deparse($kid, 6);
        }
-       $args = join(", ", @exprs);     
-       $kid = $obj . "->" . $meth;
-       if ($args) {
-           return $kid . "(" . $args . ")"; # parens mandatory
+       $meth = $kid->first;
+    }
+    $obj = $self->deparse($obj, 24);
+    if ($meth->ppaddr eq "pp_const") {
+       $meth = $meth->sv->PV; # needs to be bare
+    } else {
+       $meth = $self->deparse($meth, 1);
+    }
+    my $args = join(", ", @exprs);     
+    $kid = $obj . "->" . $meth;
+    if ($args) {
+       return $kid . "(" . $args . ")"; # parens mandatory
+    } else {
+       return $kid;
+    }
+}
+
+# returns "&" if the prototype doesn't match the args,
+# or ("", $args_after_prototype_demunging) if it does.
+sub check_proto {
+    my $self = shift;
+    my($proto, @args) = @_;
+    my($arg, $real);
+    my $doneok = 0;
+    my @reals;
+    # An unbackslashed @ or % gobbles up the rest of the args
+    $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
+    while ($proto) {
+       $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
+       my $chr = $1;
+       if ($chr eq "") {
+           return "&" if @args;
+       } elsif ($chr eq ";") {
+           $doneok = 1;
+       } elsif ($chr eq "@" or $chr eq "%") {
+           push @reals, map($self->deparse($_, 6), @args);
+           @args = ();
        } else {
-           return $kid; # toke.c fakes parens
-       }
+           $arg = shift @args;
+           last unless $arg;
+           if ($chr eq "\$") {
+               if (want_scalar $arg) {
+                   push @reals, $self->deparse($arg, 6);
+               } else {
+                   return "&";
+               }
+           } elsif ($chr eq "&") {
+               if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
+                   push @reals, $self->deparse($arg, 6);
+               } else {
+                   return "&";
+               }
+           } elsif ($chr eq "*") {
+               if ($arg->ppaddr =~ /^pp_s?refgen$/
+                   and $arg->first->first->ppaddr eq "pp_rv2gv")
+                 {
+                     $real = $arg->first->first; # skip refgen, null
+                     if ($real->first->ppaddr eq "pp_gv") {
+                         push @reals, $self->deparse($real, 6);
+                     } else {
+                         push @reals, $self->deparse($real->first, 6);
+                     }
+                 } else {
+                     return "&";
+                 }
+           } elsif (substr($chr, 0, 1) eq "\\") {
+               $chr = substr($chr, 1);
+               if ($arg->ppaddr =~ /^pp_s?refgen$/ and
+                   !null($real = $arg->first) and
+                   ($chr eq "\$" && is_scalar($real->first)
+                    or ($chr eq "\@"
+                        && $real->first->sibling->ppaddr
+                        =~ /^pp_(rv2|pad)av$/)
+                    or ($chr eq "%"
+                        && $real->first->sibling->ppaddr
+                        =~ /^pp_(rv2|pad)hv$/)
+                    #or ($chr eq "&" # This doesn't work
+                    #   && $real->first->ppaddr eq "pp_rv2cv")
+                    or ($chr eq "*"
+                        && $real->first->ppaddr eq "pp_rv2gv")))
+                 {
+                     push @reals, $self->deparse($real, 6);
+                 } else {
+                     return "&";
+                 }
+           }
+       }
     }
-    # else, not a method
+    return "&" if $proto and !$doneok; # too few args and no `;'
+    return "&" if @args;               # too many args
+    return ("", join ", ", @reals);
+}
+
+sub pp_entersub {
+    my $self = shift;
+    my($op, $cx) = @_;
+    return $self->method($op, $cx) unless null $op->first->sibling;
+    my $prefix = "";
+    my $amper = "";
+    my($kid, @exprs);
     if ($op->flags & OPf_SPECIAL) {
        $prefix = "do ";
     } elsif ($op->private & OPpENTERSUB_AMPER) {
@@ -1861,6 +2101,8 @@ sub pp_entersub {
     for (; not null $kid->sibling; $kid = $kid->sibling) {
        push @exprs, $kid;
     }
+    my $simple = 0;
+    my $proto = undef;
     if (is_scope($kid)) {
        $amper = "&";
        $kid = "{" . $self->deparse($kid, 0) . "}";
@@ -1869,7 +2111,7 @@ sub pp_entersub {
        if (class($gv->CV) ne "SPECIAL") {
            $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
        }
-       $simple = 1;
+       $simple = 1; # only calls of named functions can be prototyped
        $kid = $self->deparse($kid, 24);
     } elsif (is_scalar $kid->first) {
        $amper = "&";
@@ -1878,79 +2120,10 @@ sub pp_entersub {
        $prefix = "";
        $kid = $self->deparse($kid, 24) . "->";
     }
+    my $args;
     if (defined $proto and not $amper) {
-       my($arg, $real);
-       my $doneok = 0;
-       my @args = @exprs;
-       my @reals;
-       $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
-       while ($proto) {
-           $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
-           my $chr = $1;
-           if ($chr eq "") {
-               undef $proto if @args;
-           } elsif ($chr eq ";") {
-               $doneok = 1;
-           } elsif ($chr eq "@" or $chr eq "%") {
-               push @reals, map($self->deparse($_, 6), @args);
-               @args = ();
-           } else {
-               $arg = shift @args;
-               undef $proto, last unless $arg;
-               if ($chr eq "\$") {
-                   if (want_scalar $arg) {
-                       push @reals, $self->deparse($arg, 6);
-                   } else {
-                       undef $proto;
-                   }
-               } elsif ($chr eq "&") {
-                   if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
-                       push @reals, $self->deparse($arg, 6);
-                   } else {
-                       undef $proto;
-                   }
-               } elsif ($chr eq "*") {
-                   if ($arg->ppaddr =~ /^pp_s?refgen$/
-                       and $arg->first->first->ppaddr eq "pp_rv2gv")
-                   {
-                       $real = $arg->first->first; # skip refgen, null
-                       if ($real->first->ppaddr eq "pp_gv") {
-                           push @reals, $self->deparse($real, 6);
-                       } else {
-                           push @reals, $self->deparse($real->first, 6);
-                       }
-                   } else {
-                       undef $proto;
-                   }
-               } elsif (substr($chr, 0, 1) eq "\\") {
-                   $chr = substr($chr, 1);
-                   if ($arg->ppaddr =~ /^pp_s?refgen$/ and
-                       !null($real = $arg->first) and
-                       ($chr eq "\$" && is_scalar($real->first)
-                        or ($chr eq "\@"
-                            && $real->first->sibling->ppaddr 
-                            =~ /^pp_(rv2|pad)av$/)
-                        or ($chr eq "%"
-                            && $real->first->sibling->ppaddr
-                            =~ /^pp_(rv2|pad)hv$/)
-                        #or ($chr eq "&" # This doesn't work
-                        #   && $real->first->ppaddr eq "pp_rv2cv")
-                        or ($chr eq "*"
-                            && $real->first->ppaddr eq "pp_rv2gv")))
-                   {
-                       push @reals, $self->deparse($real, 6);
-                   } else {
-                       undef $proto;
-                   }
-               }
-           }
-       }
-       undef $proto if $proto and !$doneok;
-       undef $proto if @args;
-       $args = join(", ", @reals);
-       $amper = "";
-       unless (defined $proto) {
-           $amper = "&";
+       ($amper, $args) = $self->check_proto($proto, @exprs);
+       if ($amper eq "&") {
            $args = join(", ", map($self->deparse($_, 6), @exprs));
        }
     } else {
@@ -2028,6 +2201,7 @@ sub balanced_delim {
            } elsif ($c eq $close) {
                $cnt--;
                if ($cnt < 0) {
+                   # qq()() isn't ")("
                    $fail = 1;
                    last;
                }
@@ -2041,25 +2215,26 @@ sub balanced_delim {
 
 sub single_delim {
     my($q, $default, $str) = @_;
-    return "$default$str$default" if index($str, $default) == -1;
+    return "$default$str$default" if $default and index($str, $default) == -1;
     my($succeed, $delim);
     ($succeed, $str) = balanced_delim($str);
     return "$q$str" if $succeed;
     for $delim ('/', '"', '#') {
        return "$q$delim" . $str . $delim if index($str, $delim) == -1;
     }
-    $str =~ s/$default/\\$default/g;
-    return "$default$str$default";
+    if ($default) {
+       $str =~ s/$default/\\$default/g;
+       return "$default$str$default";
+    } else {
+       $str =~ s[/][\\/]g;
+       return "$q/$str/";
+    }
 }
 
-sub SVf_IOK () {0x10000}
-sub SVf_NOK () {0x20000}
-sub SVf_ROK () {0x80000}
-
 sub const {
     my $sv = shift;
     if (class($sv) eq "SPECIAL") {
-       return ('undef', '1', '0')[$$sv-1];
+       return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
     } elsif ($sv->FLAGS & SVf_IOK) {
        return $sv->IV;
     } elsif ($sv->FLAGS & SVf_NOK) {
@@ -2068,11 +2243,10 @@ sub const {
        return "\\(" . const($sv->RV) . ")"; # constant folded
     } else {
        my $str = $sv->PV;
-       if ($str =~ /[^ -~]/) { # ASCII
+       if ($str =~ /[^ -~]/) { # ASCII for non-printing
            return single_delim("qq", '"', uninterp escape_str unback $str);
        } else {
-           $str =~ s/\\/\\\\/g;
-           return single_delim("q", "'", $str);
+           return single_delim("q", "'", unback $str);
        }
     }
 }
@@ -2080,7 +2254,7 @@ sub const {
 sub pp_const {
     my $self = shift;
     my($op, $cx) = @_;
-#    if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting 
+#    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting 
 #      return $op->sv->PV;
 #    }
     return const($op->sv);
@@ -2120,12 +2294,13 @@ sub pp_backtick {
 
 sub dquote {
     my $self = shift;
-    my $op = shift;
+    my($op, $cx) = shift;
+    return $self->deparse($op->first->sibling, $cx) if $self->{'unquote'};
     # skip ex-stringify, pushmark
     return single_delim("qq", '"', $self->dq($op->first->sibling)); 
 }
 
-# OP_STRINGIFY is a listop, but it only ever has one arg (?)
+# OP_STRINGIFY is a listop, but it only ever has one arg
 sub pp_stringify { dquote(@_) }
 
 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
@@ -2201,10 +2376,6 @@ sub collapse {
     return $str;
 }
 
-sub OPpTRANS_SQUASH () { 16 }
-sub OPpTRANS_DELETE () { 32 }
-sub OPpTRANS_COMPLEMENT () { 64 }
-
 sub pp_trans {
     my $self = shift;
     my($op, $cx) = @_;
@@ -2286,24 +2457,10 @@ sub pp_regcomp {
     my($op, $cx) = @_;
     my $kid = $op->first;
     $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe";
+    $kid = $kid->first if $kid->ppaddr eq "pp_regcreset";
     return $self->re_dq($kid);
 }
 
-sub OPp_RUNTIME () { 64 }
-
-sub PMf_ONCE () { 0x2 }
-sub PMf_SKIPWHITE () { 0x10 }
-sub PMf_FOLD () { 0x20 }
-sub PMf_CONST () { 0x40 }
-sub PMf_KEEP () { 0x80 }
-sub PMf_GLOBAL () { 0x100 }
-sub PMf_CONTINUE () { 0x200 }
-sub PMf_EVAL () { 0x400 }
-sub PMf_MULTILINE () { 0x1000 }
-sub PMf_SINGLELINE () { 0x2000 }
-sub PMf_LOCALE () { 0x4000 }
-sub PMf_EXTENDED () { 0x8000 }
-
 # osmic acid -- see osmium tetroxide
 
 my %matchwords;
@@ -2311,9 +2468,9 @@ map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic', 
     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi'); 
 
-sub pp_match {
+sub matchop {
     my $self = shift;
-    my($op, $cx) = @_;
+    my($op, $cx, $name, $delim) = @_;
     my $kid = $op->first;
     my ($binop, $var, $re) = ("", "", "");
     if ($op->flags & OPf_STACKED) {
@@ -2339,7 +2496,7 @@ sub pp_match {
        $re =~ s/\?/\\?/g;
        $re = "?$re?";
     } else {
-       $re = single_delim("m", "/", $re);
+       $re = single_delim($name, $delim, $re);
     }
     $re = $re . $flags;
     if ($binop) {
@@ -2349,7 +2506,9 @@ sub pp_match {
     }
 }
 
-sub pp_pushre { pp_match(@_) }
+sub pp_match { matchop(@_, "m", "/") }
+sub pp_pushre { matchop(@_, "m", "/") }
+sub pp_qr { matchop(@_, "qr", "") }
 
 sub pp_split {
     my $self = shift;
@@ -2400,7 +2559,11 @@ sub pp_subst {
            $repl = $repl->first;
            $flags .= "e";
        }
-       $repl = $self->dq($repl);
+       if ($op->pmflags & PMf_EVAL) {
+           $repl = $self->deparse($repl, 0);
+       } else {
+           $repl = $self->dq($repl);   
+       }
     }
     if (null $kid) {
        $re = re_uninterp(escape_str($op->precomp));
@@ -2433,7 +2596,7 @@ B::Deparse - Perl compiler backend to produce perl code
 
 =head1 SYNOPSIS
 
-B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-s>I<LETTERS>] I<prog.pl>
+B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-l>][B<,-s>I<LETTERS>] I<prog.pl>
 
 =head1 DESCRIPTION
 
@@ -2458,6 +2621,11 @@ the '-MO=Deparse', separated by a comma but not any white space.
 
 =over 4
 
+=item B<-l>
+
+Add '#line' declarations to the output based on the line and file
+locations of the original code.
+
 =item B<-p>
 
 Print extra parentheses. Without this option, B::Deparse includes
@@ -2481,6 +2649,25 @@ C<B::Deparse,-p> will print
 which probably isn't what you intended (the C<'???'> is a sign that
 perl optimized away a constant value).
 
+=item B<-q>
+
+Expand double-quoted strings into the corresponding combinations of
+concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
+instance, print
+
+    print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
+
+as
+
+    print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
+          . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
+
+Note that the expanded form represents the way perl handles such
+constructions internally -- this option actually turns off the reverse
+translation that B::Deparse usually does. On the other hand, note that
+C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
+of $y into a string before doing the assignment.
+
 =item B<-u>I<PACKAGE>
 
 Normally, B::Deparse deparses the main code of a program, all the subs
@@ -2533,7 +2720,7 @@ See the 'to do' list at the beginning of the module file.
 
 =head1 AUTHOR
 
-Stephen McCamant <alias@mcs.com>, based on an earlier version by
-Malcolm Beattie <mbeattie@sable.ox.ac.uk>.
+Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
+version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>.
 
 =cut