ext/B/B/Deparse.pm

   1 # B::Deparse.pm
   2 # Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
   3 # This module is free software; you can redistribute and/or modify
   4 # it under the same terms as Perl itself.
   5
   6 # This is based on the module of the same name by Malcolm Beattie,
   7 # but essentially none of his code remains.
   8
   9 package B::Deparse;
  10 use Carp 'cluck', 'croak';
  11 use B qw(class main_root main_start main_cv svref_2object opnumber cstring
  12          OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
  13          OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
  14          OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
  15          OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
  16          OPpCONST_ARYBASE
  17          SVf_IOK SVf_NOK SVf_ROK SVf_POK
  18          CVf_METHOD CVf_LOCKED CVf_LVALUE
  19          PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
  20          PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
  21 $VERSION = 0.60;
  22 use strict;
  23
  24 # Changes between 0.50 and 0.51:
  25 # - fixed nulled leave with live enter in sort { }
  26 # - fixed reference constants (\"str")
  27 # - handle empty programs gracefully
  28 # - handle infinte loops (for (;;) {}, while (1) {})
  29 # - differentiate between `for my $x ...' and `my $x; for $x ...'
  30 # - various minor cleanups
  31 # - moved globals into an object
  32 # - added `-u', like B::C
  33 # - package declarations using cop_stash
  34 # - subs, formats and code sorted by cop_seq
  35 # Changes between 0.51 and 0.52:
  36 # - added pp_threadsv (special variables under USE_THREADS)
  37 # - added documentation
  38 # Changes between 0.52 and 0.53:
  39 # - many changes adding precedence contexts and associativity
  40 # - added `-p' and `-s' output style options
  41 # - various other minor fixes
  42 # Changes between 0.53 and 0.54:
  43 # - added support for new `for (1..100)' optimization,
  44 #   thanks to Gisle Aas
  45 # Changes between 0.54 and 0.55:
  46 # - added support for new qr// construct
  47 # - added support for new pp_regcreset OP
  48 # Changes between 0.55 and 0.56:
  49 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
  50 # - fixed $# on non-lexicals broken in last big rewrite
  51 # - added temporary fix for change in opcode of OP_STRINGIFY
  52 # - fixed problem in 0.54's for() patch in `for (@ary)'
  53 # - fixed precedence in conditional of ?:
  54 # - tweaked list paren elimination in `my($x) = @_'
  55 # - made continue-block detection trickier wrt. null ops
  56 # - fixed various prototype problems in pp_entersub
  57 # - added support for sub prototypes that never get GVs
  58 # - added unquoting for special filehandle first arg in truncate
  59 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
  60 # - added semicolons at the ends of blocks
  61 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
  62 # Changes between 0.56 and 0.561:
  63 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
  64 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
  65 # Changes between 0.561 and 0.57:
  66 # - stylistic changes to symbolic constant stuff
  67 # - handled scope in s///e replacement code
  68 # - added unquote option for expanding "" into concats, etc.
  69 # - split method and proto parts of pp_entersub into separate functions
  70 # - various minor cleanups
  71 # Changes after 0.57:
  72 # - added parens in \&foo (patch by Albert Dvornik)
  73 # Changes between 0.57 and 0.58:
  74 # - fixed `0' statements that weren't being printed
  75 # - added methods for use from other programs
  76 #   (based on patches from James Duncan and Hugo van der Sanden)
  77 # - added -si and -sT to control indenting (also based on a patch from Hugo)
  78 # - added -sv to print something else instead of '???'
  79 # - preliminary version of utf8 tr/// handling
  80 # Changes after 0.58:
  81 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
  82 # - added support for Hugo's new OP_SETSTATE (like nextstate)
  83 # Changes between 0.58 and 0.59
  84 # - added support for Chip's OP_METHOD_NAMED
  85 # - added support for Ilya's OPpTARGET_MY optimization
  86 # - elided arrows before `()' subscripts when possible
  87 # Changes between 0.59 and 0.60
  88 # - support for method attribues was added
  89 # - some warnings fixed
  90 # - separate recognition of constant subs
  91 # - rewrote continue block handling, now recoginizing for loops
  92 # - added more control of expanding control structures
  93
  94 # Todo:
  95 # - finish tr/// changes
  96 # - add option for even more parens (generalize \&foo change)
  97 # - left/right context
  98 # - recognize `use utf8', `use integer', etc
  99 # - treat top-level block specially for incremental output
 100 # - copy comments (look at real text with $^P?)
 101 # - avoid semis in one-statement blocks
 102 # - associativity of &&=, ||=, ?:
 103 # - ',' => '=>' (auto-unquote?)
 104 # - break long lines ("\r" as discretionary break?)
 105 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
 106 # - more style options: brace style, hex vs. octal, quotes, ...
 107 # - print big ints as hex/octal instead of decimal (heuristic?)
 108 # - handle `my $x if 0'?
 109 # - include values of variables (e.g. set in BEGIN)
 110 # - coordinate with Data::Dumper (both directions? see previous)
 111 # - version using op_next instead of op_first/sibling?
 112 # - avoid string copies (pass arrays, one big join?)
 113 # - auto-apply `-u'?
 114 # - -uPackage:: descend recursively?
 115 # - here-docs?
 116 # - <DATA>?
 117
 118 # Tests that will always fail:
 119 # comp/redef.t -- all (redefinition happens at compile time)
 120
 121 # Object fields (were globals):
 122 #
 123 # avoid_local:
 124 # (local($a), local($b)) and local($a, $b) have the same internal
 125 # representation but the short form looks better. We notice we can
 126 # use a large-scale local when checking the list, but need to prevent
 127 # individual locals too. This hash holds the addresses of OPs that
 128 # have already had their local-ness accounted for. The same thing
 129 # is done with my().
 130 #
 131 # curcv:
 132 # CV for current sub (or main program) being deparsed
 133 #
 134 # curstash:
 135 # name of the current package for deparsed code
 136 #
 137 # subs_todo:
 138 # array of [cop_seq, GV, is_format?] for subs and formats we still
 139 # want to deparse
 140 #
 141 # protos_todo:
 142 # as above, but [name, prototype] for subs that never got a GV
 143 #
 144 # subs_done, forms_done:
 145 # keys are addresses of GVs for subs and formats we've already
 146 # deparsed (or at least put into subs_todo)
 147 #
 148 # subs_declared
 149 # keys are names of subs for which we've printed declarations.
 150 # That means we can omit parentheses from the arguments.
 151 #
 152 # parens: -p
 153 # linenums: -l
 154 # unquote: -q
 155 # cuddle: ` ' or `\n', depending on -sC
 156 # indent_size: -si
 157 # use_tabs: -sT
 158 # ex_const: -sv
 159
 160 # A little explanation of how precedence contexts and associativity
 161 # work:
 162 #
 163 # deparse() calls each per-op subroutine with an argument $cx (short
 164 # for context, but not the same as the cx* in the perl core), which is
 165 # a number describing the op's parents in terms of precedence, whether
 166 # they're inside an expression or at statement level, etc.  (see
 167 # chart below). When ops with children call deparse on them, they pass
 168 # along their precedence. Fractional values are used to implement
 169 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
 170 # parentheses hacks. The major disadvantage of this scheme is that
 171 # it doesn't know about right sides and left sides, so say if you
 172 # assign a listop to a variable, it can't tell it's allowed to leave
 173 # the parens off the listop.
 174
 175 # Precedences:
 176 # 26             [TODO] inside interpolation context ("")
 177 # 25 left        terms and list operators (leftward)
 178 # 24 left        ->
 179 # 23 nonassoc    ++ --
 180 # 22 right       **
 181 # 21 right       ! ~ \ and unary + and -
 182 # 20 left        =~ !~
 183 # 19 left        * / % x
 184 # 18 left        + - .
 185 # 17 left        << >>
 186 # 16 nonassoc    named unary operators
 187 # 15 nonassoc    < > <= >= lt gt le ge
 188 # 14 nonassoc    == != <=> eq ne cmp
 189 # 13 left        &
 190 # 12 left        | ^
 191 # 11 left        &&
 192 # 10 left        ||
 193 #  9 nonassoc    ..  ...
 194 #  8 right       ?:
 195 #  7 right       = += -= *= etc.
 196 #  6 left        , =>
 197 #  5 nonassoc    list operators (rightward)
 198 #  4 right       not
 199 #  3 left        and
 200 #  2 left        or xor
 201 #  1             statement modifiers
 202 #  0             statement level
 203
 204 # Nonprinting characters with special meaning:
 205 # \cS - steal parens (see maybe_parens_unop)
 206 # \n - newline and indent
 207 # \t - increase indent
 208 # \b - decrease indent (`outdent')
 209 # \f - flush left (no indent)
 210 # \cK - kill following semicolon, if any
 211
 212 sub null {
 213     my $op = shift;
 214     return class($op) eq "NULL";
 215 }
 216
 217 sub todo {
 218     my $self = shift;
 219     my($gv, $cv, $is_form) = @_;
 220     my $seq;
 221     if (!null($cv->START) and is_state($cv->START)) {
 222         $seq = $cv->START->cop_seq;
 223     } else {
 224         $seq = 0;
 225     }
 226     push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
 227 }
 228
 229 sub next_todo {
 230     my $self = shift;
 231     my $ent = shift @{$self->{'subs_todo'}};
 232     my $name = $self->gv_name($ent->[1]);
 233     if ($ent->[2]) {
 234         return "format $name =\n"
 235             . $self->deparse_format($ent->[1]->FORM). "\n";
 236     } else {
 237         $self->{'subs_declared'}{$name} = 1;
 238         return "sub $name " . $self->deparse_sub($ent->[1]->CV);
 239     }
 240 }
 241
 242 sub walk_tree {
 243     my($op, $sub) = @_;
 244     $sub->($op);
 245     if ($op->flags & OPf_KIDS) {
 246         my $kid;
 247         for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
 248             walk_tree($kid, $sub);
 249         }
 250     }
 251 }
 252
 253 sub walk_sub {
 254     my $self = shift;
 255     my $cv = shift;
 256     my $op = $cv->ROOT;
 257     $op = shift if null $op;
 258     return if !$op or null $op;
 259     walk_tree($op, sub {
 260         my $op = shift;
 261         if ($op->name eq "gv") {
 262             my $gv = $self->gv_or_padgv($op);
 263             if ($op->next->name eq "entersub") {
 264                 return if $self->{'subs_done'}{$$gv}++;
 265                 return if class($gv->CV) eq "SPECIAL";
 266                 $self->todo($gv, $gv->CV, 0);
 267                 $self->walk_sub($gv->CV);
 268             } elsif ($op->next->name eq "enterwrite"
 269                      or ($op->next->name eq "rv2gv"
 270                          and $op->next->next->name eq "enterwrite")) {
 271                 return if $self->{'forms_done'}{$$gv}++;
 272                 return if class($gv->FORM) eq "SPECIAL";
 273                 $self->todo($gv, $gv->FORM, 1);
 274                 $self->walk_sub($gv->FORM);
 275             }
 276         }
 277     });
 278 }
 279
 280 sub stash_subs {
 281     my $self = shift;
 282     my $pack = shift;
 283     my(%stash, @ret);
 284     { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
 285     if ($pack eq "main") {
 286         $pack = "";
 287     } else {
 288         $pack = $pack . "::";
 289     }
 290     my($key, $val);
 291     while (($key, $val) = each %stash) {
 292         my $class = class($val);
 293         if ($class eq "PV") {
 294             # Just a prototype
 295             push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
 296         } elsif ($class eq "IV") {
 297             # Just a name
 298             push @{$self->{'protos_todo'}}, [$pack . $key, undef];
 299         } elsif ($class eq "GV") {
 300             if (class($val->CV) ne "SPECIAL") {
 301                 next if $self->{'subs_done'}{$$val}++;
 302                 $self->todo($val, $val->CV, 0);
 303                 $self->walk_sub($val->CV);
 304             }
 305             if (class($val->FORM) ne "SPECIAL") {
 306                 next if $self->{'forms_done'}{$$val}++;
 307                 $self->todo($val, $val->FORM, 1);
 308                 $self->walk_sub($val->FORM);
 309             }
 310         }
 311     }
 312 }
 313
 314 sub print_protos {
 315     my $self = shift;
 316     my $ar;
 317     my @ret;
 318     foreach $ar (@{$self->{'protos_todo'}}) {
 319         my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
 320         push @ret, "sub " . $ar->[0] .  "$proto;\n";
 321     }
 322     delete $self->{'protos_todo'};
 323     return @ret;
 324 }
 325
 326 sub style_opts {
 327     my $self = shift;
 328     my $opts = shift;
 329     my $opt;
 330     while (length($opt = substr($opts, 0, 1))) {
 331         if ($opt eq "C") {
 332             $self->{'cuddle'} = " ";
 333             $opts = substr($opts, 1);
 334         } elsif ($opt eq "i") {
 335             $opts =~ s/^i(\d+)//;
 336             $self->{'indent_size'} = $1;
 337         } elsif ($opt eq "T") {
 338             $self->{'use_tabs'} = 1;
 339             $opts = substr($opts, 1);
 340         } elsif ($opt eq "v") {
 341             $opts =~ s/^v([^.]*)(.|$)//;
 342             $self->{'ex_const'} = $1;
 343         }
 344     }
 345 }
 346
 347 sub new {
 348     my $class = shift;
 349     my $self = bless {}, $class;
 350     $self->{'subs_todo'} = [];
 351     $self->{'curstash'} = "main";
 352     $self->{'cuddle'} = "\n";
 353     $self->{'indent_size'} = 4;
 354     $self->{'use_tabs'} = 0;
 355     $self->{'expand'} = 0;
 356     $self->{'unquote'} = 0;
 357     $self->{'linenums'} = 0;
 358     $self->{'parens'} = 0;
 359     $self->{'ex_const'} = "'???'";
 360
 361     $self->{'ambient_arybase'} = 0;
 362     $self->{'ambient_warnings'} = "\0"x12;
 363     $self->{'ambient_hints'} = 0;
 364     $self->init();
 365
 366     while (my $arg = shift @_) {
 367         if (substr($arg, 0, 2) eq "-u") {
 368             $self->stash_subs(substr($arg, 2));
 369         } elsif ($arg eq "-p") {
 370             $self->{'parens'} = 1;
 371         } elsif ($arg eq "-l") {
 372             $self->{'linenums'} = 1;
 373         } elsif ($arg eq "-q") {
 374             $self->{'unquote'} = 1;
 375         } elsif (substr($arg, 0, 2) eq "-s") {
 376             $self->style_opts(substr $arg, 2);
 377         } elsif ($arg =~ /^-x(\d)$/) {
 378             $self->{'expand'} = $1;
 379         }
 380     }
 381     return $self;
 382 }
 383
 384 # Initialise the contextual information, either from
 385 # defaults provided with the ambient_pragmas method,
 386 # or from perl's own defaults otherwise.
 387 sub init {
 388     my $self = shift;
 389
 390     $self->{'arybase'}  = $self->{'ambient_arybase'};
 391     $self->{'warnings'} = $self->{'ambient_warnings'};
 392     $self->{'hints'}    = $self->{'ambient_hints'} & 0xFF;
 393
 394     # also a convenient place to clear out subs_declared
 395     delete $self->{'subs_declared'};
 396 }
 397
 398 sub compile {
 399     my(@args) = @_;
 400     return sub {
 401         my $self = B::Deparse->new(@args);
 402         $self->stash_subs("main");
 403         $self->{'curcv'} = main_cv;
 404         $self->walk_sub(main_cv, main_start);
 405         print $self->print_protos;
 406         @{$self->{'subs_todo'}} =
 407           sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
 408         print $self->indent($self->deparse(main_root, 0)), "\n"
 409           unless null main_root;
 410         my @text;
 411         while (scalar(@{$self->{'subs_todo'}})) {
 412             push @text, $self->next_todo;
 413         }
 414         print $self->indent(join("", @text)), "\n" if @text;
 415     }
 416 }
 417
 418 sub coderef2text {
 419     my $self = shift;
 420     my $sub = shift;
 421     croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
 422
 423     $self->init();
 424     return $self->indent($self->deparse_sub(svref_2object($sub)));
 425 }
 426
 427 sub ambient_pragmas {
 428     my $self = shift;
 429     my ($arybase, $hint_bits, $warning_bits) = (0, 0, "\0"x12);
 430
 431     while (@_ > 1) {
 432         my $name = shift();
 433         my $val  = shift();
 434
 435         if ($name eq 'strict') {
 436             require strict;
 437
 438             if ($val eq 'none') {
 439                 $hint_bits &= ~strict::bits(qw/refs subs vars/);
 440                 next();
 441             }
 442
 443             my @names;
 444             if ($val eq "all") {
 445                 @names = qw/refs subs vars/;
 446             }
 447             elsif (ref $val) {
 448                 @names = @$val;
 449             }
 450             else {
 451                 @names = split' ', $val;
 452             }
 453             $hint_bits |= strict::bits(@names);
 454         }
 455
 456         elsif ($name eq '$[') {
 457             $arybase = $val;
 458         }
 459
 460         elsif ($name eq 'integer'
 461             || $name eq 'bytes'
 462             || $name eq 'utf8') {
 463             require "$name.pm";
 464             if ($val) {
 465                 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
 466             }
 467             else {
 468                 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
 469             }
 470         }
 471
 472         elsif ($name eq 're') {
 473             require re;
 474             if ($val eq 'none') {
 475                 $hint_bits &= ~re::bits(qw/taint eval asciirange/);
 476                 next();
 477             }
 478
 479             my @names;
 480             if ($val eq 'all') {
 481                 @names = qw/taint eval asciirange/;
 482             }
 483             elsif (ref $val) {
 484                 @names = @$val;
 485             }
 486             else {
 487                 @names = split' ',$val;
 488             }
 489             $hint_bits |= re::bits(@names);
 490         }
 491
 492         elsif ($name eq 'warnings') {
 493             require warnings;
 494             if ($val eq 'none') {
 495                 $warning_bits = "\0"x12;
 496                 next();
 497             }
 498
 499             my @names;
 500             if (ref $val) {
 501                 @names = @$val;
 502             }
 503             else {
 504                 @names = split/\s+/, $val;
 505             }
 506
 507             $warning_bits |= warnings::bits(@names);
 508         }
 509
 510         elsif ($name eq 'warning_bits') {
 511             $warning_bits = $val;
 512         }
 513
 514         elsif ($name eq 'hint_bits') {
 515             $hint_bits = $val;
 516         }
 517
 518         else {
 519             croak "Unknown pragma type: $name";
 520         }
 521     }
 522     if (@_) {
 523         croak "The ambient_pragmas method expects an even number of args";
 524     }
 525
 526     $self->{'ambient_arybase'} = $arybase;
 527     $self->{'ambient_warnings'} = $warning_bits;
 528     $self->{'ambient_hints'} = $hint_bits;
 529 }
 530
 531 sub deparse {
 532     my $self = shift;
 533     my($op, $cx) = @_;
 534 #    cluck if class($op) eq "NULL";
 535 #    cluck unless $op;
 536 #    return $self->$ {\("pp_" . $op->name)}($op, $cx);
 537 require Carp;
 538 Carp::confess() unless defined $op;
 539     my $meth = "pp_" . $op->name;
 540     return $self->$meth($op, $cx);
 541 }
 542
 543 sub indent {
 544     my $self = shift;
 545     my $txt = shift;
 546     my @lines = split(/\n/, $txt);
 547     my $leader = "";
 548     my $level = 0;
 549     my $line;
 550     for $line (@lines) {
 551         my $cmd = substr($line, 0, 1);
 552         if ($cmd eq "\t" or $cmd eq "\b") {
 553             $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
 554             if ($self->{'use_tabs'}) {
 555                 $leader = "\t" x ($level / 8) . " " x ($level % 8);
 556             } else {
 557                 $leader = " " x $level;
 558             }
 559             $line = substr($line, 1);
 560         }
 561         if (substr($line, 0, 1) eq "\f") {
 562             $line = substr($line, 1); # no indent
 563         } else {
 564             $line = $leader . $line;
 565         }
 566         $line =~ s/\cK;?//g;
 567     }
 568     return join("\n", @lines);
 569 }
 570
 571 sub deparse_sub {
 572     my $self = shift;
 573     my $cv = shift;
 574     my $proto = "";
 575     if ($cv->FLAGS & SVf_POK) {
 576         $proto = "(". $cv->PV . ") ";
 577     }
 578     if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
 579         $proto .= ": ";
 580         $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
 581         $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
 582         $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
 583     }
 584
 585     local($self->{'curcv'}) = $cv;
 586     local(@$self{qw'curstash warnings hints'})
 587                 = @$self{qw'curstash warnings hints'};
 588     if (not null $cv->ROOT) {
 589         # skip leavesub
 590         return $proto . "{\n\t" .
 591             $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
 592     }
 593     my $sv = $cv->const_sv;
 594     if ($$sv) {
 595         # uh-oh. inlinable sub... format it differently
 596         return $proto . "{ " . const($sv) . " }\n";
 597     } else { # XSUB?
 598         return $proto  . "{}\n";
 599     }
 600 }
 601
 602 sub deparse_format {
 603     my $self = shift;
 604     my $form = shift;
 605     my @text;
 606     local($self->{'curcv'}) = $form;
 607     local(@$self{qw'curstash warnings hints'})
 608                 = @$self{'curstash warnings hints'};
 609     my $op = $form->ROOT;
 610     my $kid;
 611     $op = $op->first->first; # skip leavewrite, lineseq
 612     while (not null $op) {
 613         $op = $op->sibling; # skip nextstate
 614         my @exprs;
 615         $kid = $op->first->sibling; # skip pushmark
 616         push @text, $self->const_sv($kid)->PV;
 617         $kid = $kid->sibling;
 618         for (; not null $kid; $kid = $kid->sibling) {
 619             push @exprs, $self->deparse($kid, 0);
 620         }
 621         push @text, join(", ", @exprs)."\n" if @exprs;
 622         $op = $op->sibling;
 623     }
 624     return join("", @text) . ".";
 625 }
 626
 627 sub is_scope {
 628     my $op = shift;
 629     return $op->name eq "leave" || $op->name eq "scope"
 630       || $op->name eq "lineseq"
 631         || ($op->name eq "null" && class($op) eq "UNOP"
 632             && (is_scope($op->first) || $op->first->name eq "enter"));
 633 }
 634
 635 sub is_state {
 636     my $name = $_[0]->name;
 637     return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
 638 }
 639
 640 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
 641     my $op = shift;
 642     return (!null($op) and null($op->sibling)
 643             and $op->name eq "null" and class($op) eq "UNOP"
 644             and (($op->first->name =~ /^(and|or)$/
 645                   and $op->first->first->sibling->name eq "lineseq")
 646                  or ($op->first->name eq "lineseq"
 647                      and not null $op->first->first->sibling
 648                      and $op->first->first->sibling->name eq "unstack")
 649                  ));
 650 }
 651
 652 sub is_scalar {
 653     my $op = shift;
 654     return ($op->name eq "rv2sv" or
 655             $op->name eq "padsv" or
 656             $op->name eq "gv" or # only in array/hash constructs
 657             $op->flags & OPf_KIDS && !null($op->first)
 658               && $op->first->name eq "gvsv");
 659 }
 660
 661 sub maybe_parens {
 662     my $self = shift;
 663     my($text, $cx, $prec) = @_;
 664     if ($prec < $cx              # unary ops nest just fine
 665         or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
 666         or $self->{'parens'})
 667     {
 668         $text = "($text)";
 669         # In a unop, let parent reuse our parens; see maybe_parens_unop
 670         $text = "\cS" . $text if $cx == 16;
 671         return $text;
 672     } else {
 673         return $text;
 674     }
 675 }
 676
 677 # same as above, but get around the `if it looks like a function' rule
 678 sub maybe_parens_unop {
 679     my $self = shift;
 680     my($name, $kid, $cx) = @_;
 681     if ($cx > 16 or $self->{'parens'}) {
 682         return "$name(" . $self->deparse($kid, 1) . ")";
 683     } else {
 684         $kid = $self->deparse($kid, 16);
 685         if (substr($kid, 0, 1) eq "\cS") {
 686             # use kid's parens
 687             return $name . substr($kid, 1);
 688         } elsif (substr($kid, 0, 1) eq "(") {
 689             # avoid looks-like-a-function trap with extra parens
 690             # (`+' can lead to ambiguities)
 691             return "$name(" . $kid  . ")";
 692         } else {
 693             return "$name $kid";
 694         }
 695     }
 696 }
 697
 698 sub maybe_parens_func {
 699     my $self = shift;
 700     my($func, $text, $cx, $prec) = @_;
 701     if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
 702         return "$func($text)";
 703     } else {
 704         return "$func $text";
 705     }
 706 }
 707
 708 sub maybe_local {
 709     my $self = shift;
 710     my($op, $cx, $text) = @_;
 711     if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
 712         if (want_scalar($op)) {
 713             return "local $text";
 714         } else {
 715             return $self->maybe_parens_func("local", $text, $cx, 16);
 716         }
 717     } else {
 718         return $text;
 719     }
 720 }
 721
 722 sub maybe_targmy {
 723     my $self = shift;
 724     my($op, $cx, $func, @args) = @_;
 725     if ($op->private & OPpTARGET_MY) {
 726         my $var = $self->padname($op->targ);
 727         my $val = $func->($self, $op, 7, @args);
 728         return $self->maybe_parens("$var = $val", $cx, 7);
 729     } else {
 730         return $func->($self, $op, $cx, @args);
 731     }
 732 }
 733
 734 sub padname_sv {
 735     my $self = shift;
 736     my $targ = shift;
 737     return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
 738 }
 739
 740 sub maybe_my {
 741     my $self = shift;
 742     my($op, $cx, $text) = @_;
 743     if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
 744         if (want_scalar($op)) {
 745             return "my $text";
 746         } else {
 747             return $self->maybe_parens_func("my", $text, $cx, 16);
 748         }
 749     } else {
 750         return $text;
 751     }
 752 }
 753
 754 # The following OPs don't have functions:
 755
 756 # pp_padany -- does not exist after parsing
 757 # pp_rcatline -- does not exist
 758
 759 sub pp_enter { # see also leave
 760     cluck "unexpected OP_ENTER";
 761     return "XXX";
 762 }
 763
 764 sub pp_pushmark { # see also list
 765     cluck "unexpected OP_PUSHMARK";
 766     return "XXX";
 767 }
 768
 769 sub pp_leavesub { # see also deparse_sub
 770     cluck "unexpected OP_LEAVESUB";
 771     return "XXX";
 772 }
 773
 774 sub pp_leavewrite { # see also deparse_format
 775     cluck "unexpected OP_LEAVEWRITE";
 776     return "XXX";
 777 }
 778
 779 sub pp_method { # see also entersub
 780     cluck "unexpected OP_METHOD";
 781     return "XXX";
 782 }
 783
 784 sub pp_regcmaybe { # see also regcomp
 785     cluck "unexpected OP_REGCMAYBE";
 786     return "XXX";
 787 }
 788
 789 sub pp_regcreset { # see also regcomp
 790     cluck "unexpected OP_REGCRESET";
 791     return "XXX";
 792 }
 793
 794 sub pp_substcont { # see also subst
 795     cluck "unexpected OP_SUBSTCONT";
 796     return "XXX";
 797 }
 798
 799 sub pp_grepstart { # see also grepwhile
 800     cluck "unexpected OP_GREPSTART";
 801     return "XXX";
 802 }
 803
 804 sub pp_mapstart { # see also mapwhile
 805     cluck "unexpected OP_MAPSTART";
 806     return "XXX";
 807 }
 808
 809 sub pp_flip { # see also flop
 810     cluck "unexpected OP_FLIP";
 811     return "XXX";
 812 }
 813
 814 sub pp_iter { # see also leaveloop
 815     cluck "unexpected OP_ITER";
 816     return "XXX";
 817 }
 818
 819 sub pp_enteriter { # see also leaveloop
 820     cluck "unexpected OP_ENTERITER";
 821     return "XXX";
 822 }
 823
 824 sub pp_enterloop { # see also leaveloop
 825     cluck "unexpected OP_ENTERLOOP";
 826     return "XXX";
 827 }
 828
 829 sub pp_leaveeval { # see also entereval
 830     cluck "unexpected OP_LEAVEEVAL";
 831     return "XXX";
 832 }
 833
 834 sub pp_entertry { # see also leavetry
 835     cluck "unexpected OP_ENTERTRY";
 836     return "XXX";
 837 }
 838
 839 sub lineseq {
 840     my $self = shift;
 841     my(@ops) = @_;
 842     my($expr, @exprs);
 843     for (my $i = 0; $i < @ops; $i++) {
 844         $expr = "";
 845         if (is_state $ops[$i]) {
 846             $expr = $self->deparse($ops[$i], 0);
 847             $i++;
 848             last if $i > $#ops;
 849         }
 850         if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
 851             $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
 852         {
 853             push @exprs, $expr . $self->for_loop($ops[$i], 0);
 854             $i++;
 855             next;
 856         }
 857         $expr .= $self->deparse($ops[$i], 0);
 858         push @exprs, $expr if length $expr;
 859     }
 860     for(@exprs[0..@exprs-1]) { s/;\n\z// }
 861     return join(";\n", @exprs);
 862 }
 863
 864 sub scopeop {
 865     my($real_block, $self, $op, $cx) = @_;
 866     my $kid;
 867     my @kids;
 868
 869     local(@$self{qw'curstash warnings hints'})
 870                 = @$self{qw'curstash warnings hints'} if $real_block;
 871     if ($real_block) {
 872         $kid = $op->first->sibling; # skip enter
 873         if (is_miniwhile($kid)) {
 874             my $top = $kid->first;
 875             my $name = $top->name;
 876             if ($name eq "and") {
 877                 $name = "while";
 878             } elsif ($name eq "or") {
 879                 $name = "until";
 880             } else { # no conditional -> while 1 or until 0
 881                 return $self->deparse($top->first, 1) . " while 1";
 882             }
 883             my $cond = $top->first;
 884             my $body = $cond->sibling->first; # skip lineseq
 885             $cond = $self->deparse($cond, 1);
 886             $body = $self->deparse($body, 1);
 887             return "$body $name $cond";
 888         }
 889     } else {
 890         $kid = $op->first;
 891     }
 892     for (; !null($kid); $kid = $kid->sibling) {
 893         push @kids, $kid;
 894     }
 895     if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
 896         return "do { " . $self->lineseq(@kids) . " }";
 897     } else {
 898         my $lineseq = $self->lineseq(@kids);
 899         return (length ($lineseq) ? "$lineseq;" : "");
 900     }
 901 }
 902
 903 sub pp_scope { scopeop(0, @_); }
 904 sub pp_lineseq { scopeop(0, @_); }
 905 sub pp_leave { scopeop(1, @_); }
 906
 907 # The BEGIN {} is used here because otherwise this code isn't executed
 908 # when you run B::Deparse on itself.
 909 my %globalnames;
 910 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
 911             "ENV", "ARGV", "ARGVOUT", "_"); }
 912
 913 sub gv_name {
 914     my $self = shift;
 915     my $gv = shift;
 916     my $stash = $gv->STASH->NAME;
 917     my $name = $gv->SAFENAME;
 918     if ($stash eq $self->{'curstash'} or $globalnames{$name}
 919         or $name =~ /^[^A-Za-z_]/)
 920     {
 921         $stash = "";
 922     } else {
 923         $stash = $stash . "::";
 924     }
 925     if ($name =~ /^\^../) {
 926         $name = "{$name}";       # ${^WARNING_BITS} etc
 927     }
 928     return $stash . $name;
 929 }
 930
 931 # Notice how subs and formats are inserted between statements here;
 932 # also $[ assignments and pragmas.
 933 sub pp_nextstate {
 934     my $self = shift;
 935     my($op, $cx) = @_;
 936     my @text;
 937     @text = $op->label . ": " if $op->label;
 938     my $seq = $op->cop_seq;
 939     while (scalar(@{$self->{'subs_todo'}})
 940            and $seq >= $self->{'subs_todo'}[0][0]) {
 941         push @text, $self->next_todo;
 942     }
 943     my $stash = $op->stashpv;
 944     if ($stash ne $self->{'curstash'}) {
 945         push @text, "package $stash;\n";
 946         $self->{'curstash'} = $stash;
 947     }
 948     if ($self->{'linenums'}) {
 949         push @text, "\f#line " . $op->line .
 950           ' "' . $op->file, qq'"\n';
 951     }
 952
 953     if ($self->{'arybase'} != $op->arybase) {
 954         push @text, '$[ = '. $op->arybase .";\n";
 955         $self->{'arybase'} = $op->arybase;
 956     }
 957
 958     my $warnings = $op->warnings;
 959     my $warning_bits;
 960     if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
 961         $warning_bits = $warnings::Bits{"all"};
 962     }
 963     elsif ($warnings->isa("B::SPECIAL")) {
 964         $warning_bits = "\0"x12;
 965     }
 966     else {
 967         $warning_bits = $warnings->PV;
 968     }
 969
 970     if ($self->{'warnings'} ne $warning_bits) {
 971         push @text, declare_warnings($self->{'warnings'}, $warning_bits);
 972         $self->{'warnings'} = $warning_bits;
 973     }
 974
 975     if ($self->{'hints'} != $op->private) {
 976         push @text, declare_hints($self->{'hints'}, $op->private);
 977         $self->{'hints'} = $op->private;
 978     }
 979
 980     return join("", @text);
 981 }
 982
 983 sub declare_warnings {
 984     my ($from, $to) = @_;
 985     require warnings;
 986     if ($to eq warnings::bits("all")) {
 987         return "use warnings;\n";
 988     }
 989     elsif ($to eq "\0"x12) {
 990         return "no warnings;\n";
 991     }
 992     return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
 993 }
 994
 995 sub declare_hints {
 996     my ($from, $to) = @_;
 997     my $bits = $to;
 998     return sprintf "BEGIN {\$^H &= ~0xFF; \$^H |= %x}\n", $bits;
 999 }
1000
1001 sub pp_dbstate { pp_nextstate(@_) }
1002 sub pp_setstate { pp_nextstate(@_) }
1003
1004 sub pp_unstack { return "" } # see also leaveloop
1005
1006 sub baseop {
1007     my $self = shift;
1008     my($op, $cx, $name) = @_;
1009     return $name;
1010 }
1011
1012 sub pp_stub { baseop(@_, "()") }
1013 sub pp_wantarray { baseop(@_, "wantarray") }
1014 sub pp_fork { baseop(@_, "fork") }
1015 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1016 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1017 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1018 sub pp_tms { baseop(@_, "times") }
1019 sub pp_ghostent { baseop(@_, "gethostent") }
1020 sub pp_gnetent { baseop(@_, "getnetent") }
1021 sub pp_gprotoent { baseop(@_, "getprotoent") }
1022 sub pp_gservent { baseop(@_, "getservent") }
1023 sub pp_ehostent { baseop(@_, "endhostent") }
1024 sub pp_enetent { baseop(@_, "endnetent") }
1025 sub pp_eprotoent { baseop(@_, "endprotoent") }
1026 sub pp_eservent { baseop(@_, "endservent") }
1027 sub pp_gpwent { baseop(@_, "getpwent") }
1028 sub pp_spwent { baseop(@_, "setpwent") }
1029 sub pp_epwent { baseop(@_, "endpwent") }
1030 sub pp_ggrent { baseop(@_, "getgrent") }
1031 sub pp_sgrent { baseop(@_, "setgrent") }
1032 sub pp_egrent { baseop(@_, "endgrent") }
1033 sub pp_getlogin { baseop(@_, "getlogin") }
1034
1035 sub POSTFIX () { 1 }
1036
1037 # I couldn't think of a good short name, but this is the category of
1038 # symbolic unary operators with interesting precedence
1039
1040 sub pfixop {
1041     my $self = shift;
1042     my($op, $cx, $name, $prec, $flags) = (@_, 0);
1043     my $kid = $op->first;
1044     $kid = $self->deparse($kid, $prec);
1045     return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1046                                $cx, $prec);
1047 }
1048
1049 sub pp_preinc { pfixop(@_, "++", 23) }
1050 sub pp_predec { pfixop(@_, "--", 23) }
1051 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1052 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1053 sub pp_i_preinc { pfixop(@_, "++", 23) }
1054 sub pp_i_predec { pfixop(@_, "--", 23) }
1055 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1056 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1057 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1058
1059 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1060 sub real_negate {
1061     my $self = shift;
1062     my($op, $cx) = @_;
1063     if ($op->first->name =~ /^(i_)?negate$/) {
1064         # avoid --$x
1065         $self->pfixop($op, $cx, "-", 21.5);
1066     } else {
1067         $self->pfixop($op, $cx, "-", 21);
1068     }
1069 }
1070 sub pp_i_negate { pp_negate(@_) }
1071
1072 sub pp_not {
1073     my $self = shift;
1074     my($op, $cx) = @_;
1075     if ($cx <= 4) {
1076         $self->pfixop($op, $cx, "not ", 4);
1077     } else {
1078         $self->pfixop($op, $cx, "!", 21);
1079     }
1080 }
1081
1082 sub unop {
1083     my $self = shift;
1084     my($op, $cx, $name) = @_;
1085     my $kid;
1086     if ($op->flags & OPf_KIDS) {
1087         $kid = $op->first;
1088         return $self->maybe_parens_unop($name, $kid, $cx);
1089     } else {
1090         return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
1091     }
1092 }
1093
1094 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1095 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1096 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1097 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1098 sub pp_defined { unop(@_, "defined") }
1099 sub pp_undef { unop(@_, "undef") }
1100 sub pp_study { unop(@_, "study") }
1101 sub pp_ref { unop(@_, "ref") }
1102 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1103
1104 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1105 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1106 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1107 sub pp_srand { unop(@_, "srand") }
1108 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1109 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1110 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1111 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1112 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1113 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1114 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1115
1116 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1117 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1118 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1119
1120 sub pp_each { unop(@_, "each") }
1121 sub pp_values { unop(@_, "values") }
1122 sub pp_keys { unop(@_, "keys") }
1123 sub pp_pop { unop(@_, "pop") }
1124 sub pp_shift { unop(@_, "shift") }
1125
1126 sub pp_caller { unop(@_, "caller") }
1127 sub pp_reset { unop(@_, "reset") }
1128 sub pp_exit { unop(@_, "exit") }
1129 sub pp_prototype { unop(@_, "prototype") }
1130
1131 sub pp_close { unop(@_, "close") }
1132 sub pp_fileno { unop(@_, "fileno") }
1133 sub pp_umask { unop(@_, "umask") }
1134 sub pp_untie { unop(@_, "untie") }
1135 sub pp_tied { unop(@_, "tied") }
1136 sub pp_dbmclose { unop(@_, "dbmclose") }
1137 sub pp_getc { unop(@_, "getc") }
1138 sub pp_eof { unop(@_, "eof") }
1139 sub pp_tell { unop(@_, "tell") }
1140 sub pp_getsockname { unop(@_, "getsockname") }
1141 sub pp_getpeername { unop(@_, "getpeername") }
1142
1143 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1144 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1145 sub pp_readlink { unop(@_, "readlink") }
1146 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1147 sub pp_readdir { unop(@_, "readdir") }
1148 sub pp_telldir { unop(@_, "telldir") }
1149 sub pp_rewinddir { unop(@_, "rewinddir") }
1150 sub pp_closedir { unop(@_, "closedir") }
1151 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1152 sub pp_localtime { unop(@_, "localtime") }
1153 sub pp_gmtime { unop(@_, "gmtime") }
1154 sub pp_alarm { unop(@_, "alarm") }
1155 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1156
1157 sub pp_dofile { unop(@_, "do") }
1158 sub pp_entereval { unop(@_, "eval") }
1159
1160 sub pp_ghbyname { unop(@_, "gethostbyname") }
1161 sub pp_gnbyname { unop(@_, "getnetbyname") }
1162 sub pp_gpbyname { unop(@_, "getprotobyname") }
1163 sub pp_shostent { unop(@_, "sethostent") }
1164 sub pp_snetent { unop(@_, "setnetent") }
1165 sub pp_sprotoent { unop(@_, "setprotoent") }
1166 sub pp_sservent { unop(@_, "setservent") }
1167 sub pp_gpwnam { unop(@_, "getpwnam") }
1168 sub pp_gpwuid { unop(@_, "getpwuid") }
1169 sub pp_ggrnam { unop(@_, "getgrnam") }
1170 sub pp_ggrgid { unop(@_, "getgrgid") }
1171
1172 sub pp_lock { unop(@_, "lock") }
1173
1174 sub pp_exists {
1175     my $self = shift;
1176     my($op, $cx) = @_;
1177     return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1178                                     $cx, 16);
1179 }
1180
1181 sub pp_delete {
1182     my $self = shift;
1183     my($op, $cx) = @_;
1184     my $arg;
1185     if ($op->private & OPpSLICE) {
1186         return $self->maybe_parens_func("delete",
1187                                         $self->pp_hslice($op->first, 16),
1188                                         $cx, 16);
1189     } else {
1190         return $self->maybe_parens_func("delete",
1191                                         $self->pp_helem($op->first, 16),
1192                                         $cx, 16);
1193     }
1194 }
1195
1196 sub pp_require {
1197     my $self = shift;
1198     my($op, $cx) = @_;
1199     if (class($op) eq "UNOP" and $op->first->name eq "const"
1200         and $op->first->private & OPpCONST_BARE)
1201     {
1202         my $name = $self->const_sv($op->first)->PV;
1203         $name =~ s[/][::]g;
1204         $name =~ s/\.pm//g;
1205         return "require($name)";
1206     } else {
1207         $self->unop($op, $cx, "require");
1208     }
1209 }
1210
1211 sub pp_scalar {
1212     my $self = shift;
1213     my($op, $cv) = @_;
1214     my $kid = $op->first;
1215     if (not null $kid->sibling) {
1216         # XXX Was a here-doc
1217         return $self->dquote($op);
1218     }
1219     $self->unop(@_, "scalar");
1220 }
1221
1222
1223 sub padval {
1224     my $self = shift;
1225     my $targ = shift;
1226     #cluck "curcv was undef" unless $self->{curcv};
1227     return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1228 }
1229
1230 sub pp_refgen {
1231     my $self = shift;
1232     my($op, $cx) = @_;
1233     my $kid = $op->first;
1234     if ($kid->name eq "null") {
1235         $kid = $kid->first;
1236         if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1237             my($pre, $post) = @{{"anonlist" => ["[","]"],
1238                                  "anonhash" => ["{","}"]}->{$kid->name}};
1239             my($expr, @exprs);
1240             $kid = $kid->first->sibling; # skip pushmark
1241             for (; !null($kid); $kid = $kid->sibling) {
1242                 $expr = $self->deparse($kid, 6);
1243                 push @exprs, $expr;
1244             }
1245             return $pre . join(", ", @exprs) . $post;
1246         } elsif (!null($kid->sibling) and
1247                  $kid->sibling->name eq "anoncode") {
1248             return "sub " .
1249                 $self->deparse_sub($self->padval($kid->sibling->targ));
1250         } elsif ($kid->name eq "pushmark") {
1251             my $sib_name = $kid->sibling->name;
1252             if ($sib_name =~ /^(pad|rv2)[ah]v$/
1253                 and not $kid->sibling->flags & OPf_REF)
1254             {
1255                 # The @a in \(@a) isn't in ref context, but only when the
1256                 # parens are there.
1257                 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1258             } elsif ($sib_name eq 'entersub') {
1259                 my $text = $self->deparse($kid->sibling, 1);
1260                 # Always show parens for \(&func()), but only with -p otherwise
1261                 $text = "($text)" if $self->{'parens'}
1262                                  or $kid->sibling->private & OPpENTERSUB_AMPER;
1263                 return "\\$text";
1264             }
1265         }
1266     }
1267     $self->pfixop($op, $cx, "\\", 20);
1268 }
1269
1270 sub pp_srefgen { pp_refgen(@_) }
1271
1272 sub pp_readline {
1273     my $self = shift;
1274     my($op, $cx) = @_;
1275     my $kid = $op->first;
1276     $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1277     return "<" . $self->deparse($kid, 1) . ">";
1278 }
1279
1280 # Unary operators that can occur as pseudo-listops inside double quotes
1281 sub dq_unop {
1282     my $self = shift;
1283     my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1284     my $kid;
1285     if ($op->flags & OPf_KIDS) {
1286        $kid = $op->first;
1287        # If there's more than one kid, the first is an ex-pushmark.
1288        $kid = $kid->sibling if not null $kid->sibling;
1289        return $self->maybe_parens_unop($name, $kid, $cx);
1290     } else {
1291        return $name .  ($op->flags & OPf_SPECIAL ? "()" : "");
1292     }
1293 }
1294
1295 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1296 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1297 sub pp_uc { dq_unop(@_, "uc") }
1298 sub pp_lc { dq_unop(@_, "lc") }
1299 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1300
1301 sub loopex {
1302     my $self = shift;
1303     my ($op, $cx, $name) = @_;
1304     if (class($op) eq "PVOP") {
1305         return "$name " . $op->pv;
1306     } elsif (class($op) eq "OP") {
1307         return $name;
1308     } elsif (class($op) eq "UNOP") {
1309         # Note -- loop exits are actually exempt from the
1310         # looks-like-a-func rule, but a few extra parens won't hurt
1311         return $self->maybe_parens_unop($name, $op->first, $cx);
1312     }
1313 }
1314
1315 sub pp_last { loopex(@_, "last") }
1316 sub pp_next { loopex(@_, "next") }
1317 sub pp_redo { loopex(@_, "redo") }
1318 sub pp_goto { loopex(@_, "goto") }
1319 sub pp_dump { loopex(@_, "dump") }
1320
1321 sub ftst {
1322     my $self = shift;
1323     my($op, $cx, $name) = @_;
1324     if (class($op) eq "UNOP") {
1325         # Genuine `-X' filetests are exempt from the LLAFR, but not
1326         # l?stat(); for the sake of clarity, give'em all parens
1327         return $self->maybe_parens_unop($name, $op->first, $cx);
1328     } elsif (class($op) eq "SVOP") {
1329         return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1330     } else { # I don't think baseop filetests ever survive ck_ftst, but...
1331         return $name;
1332     }
1333 }
1334
1335 sub pp_lstat { ftst(@_, "lstat") }
1336 sub pp_stat { ftst(@_, "stat") }
1337 sub pp_ftrread { ftst(@_, "-R") }
1338 sub pp_ftrwrite { ftst(@_, "-W") }
1339 sub pp_ftrexec { ftst(@_, "-X") }
1340 sub pp_fteread { ftst(@_, "-r") }
1341 sub pp_ftewrite { ftst(@_, "-r") }
1342 sub pp_fteexec { ftst(@_, "-r") }
1343 sub pp_ftis { ftst(@_, "-e") }
1344 sub pp_fteowned { ftst(@_, "-O") }
1345 sub pp_ftrowned { ftst(@_, "-o") }
1346 sub pp_ftzero { ftst(@_, "-z") }
1347 sub pp_ftsize { ftst(@_, "-s") }
1348 sub pp_ftmtime { ftst(@_, "-M") }
1349 sub pp_ftatime { ftst(@_, "-A") }
1350 sub pp_ftctime { ftst(@_, "-C") }
1351 sub pp_ftsock { ftst(@_, "-S") }
1352 sub pp_ftchr { ftst(@_, "-c") }
1353 sub pp_ftblk { ftst(@_, "-b") }
1354 sub pp_ftfile { ftst(@_, "-f") }
1355 sub pp_ftdir { ftst(@_, "-d") }
1356 sub pp_ftpipe { ftst(@_, "-p") }
1357 sub pp_ftlink { ftst(@_, "-l") }
1358 sub pp_ftsuid { ftst(@_, "-u") }
1359 sub pp_ftsgid { ftst(@_, "-g") }
1360 sub pp_ftsvtx { ftst(@_, "-k") }
1361 sub pp_fttty { ftst(@_, "-t") }
1362 sub pp_fttext { ftst(@_, "-T") }
1363 sub pp_ftbinary { ftst(@_, "-B") }
1364
1365 sub SWAP_CHILDREN () { 1 }
1366 sub ASSIGN () { 2 } # has OP= variant
1367
1368 my(%left, %right);
1369
1370 sub assoc_class {
1371     my $op = shift;
1372     my $name = $op->name;
1373     if ($name eq "concat" and $op->first->name eq "concat") {
1374         # avoid spurious `=' -- see comment in pp_concat
1375         return "concat";
1376     }
1377     if ($name eq "null" and class($op) eq "UNOP"
1378         and $op->first->name =~ /^(and|x?or)$/
1379         and null $op->first->sibling)
1380     {
1381         # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1382         # with a null that's used as the common end point of the two
1383         # flows of control. For precedence purposes, ignore it.
1384         # (COND_EXPRs have these too, but we don't bother with
1385         # their associativity).
1386         return assoc_class($op->first);
1387     }
1388     return $name . ($op->flags & OPf_STACKED ? "=" : "");
1389 }
1390
1391 # Left associative operators, like `+', for which
1392 # $a + $b + $c is equivalent to ($a + $b) + $c
1393
1394 BEGIN {
1395     %left = ('multiply' => 19, 'i_multiply' => 19,
1396              'divide' => 19, 'i_divide' => 19,
1397              'modulo' => 19, 'i_modulo' => 19,
1398              'repeat' => 19,
1399              'add' => 18, 'i_add' => 18,
1400              'subtract' => 18, 'i_subtract' => 18,
1401              'concat' => 18,
1402              'left_shift' => 17, 'right_shift' => 17,
1403              'bit_and' => 13,
1404              'bit_or' => 12, 'bit_xor' => 12,
1405              'and' => 3,
1406              'or' => 2, 'xor' => 2,
1407             );
1408 }
1409
1410 sub deparse_binop_left {
1411     my $self = shift;
1412     my($op, $left, $prec) = @_;
1413     if ($left{assoc_class($op)} && $left{assoc_class($left)}
1414         and $left{assoc_class($op)} == $left{assoc_class($left)})
1415     {
1416         return $self->deparse($left, $prec - .00001);
1417     } else {
1418         return $self->deparse($left, $prec);
1419     }
1420 }
1421
1422 # Right associative operators, like `=', for which
1423 # $a = $b = $c is equivalent to $a = ($b = $c)
1424
1425 BEGIN {
1426     %right = ('pow' => 22,
1427               'sassign=' => 7, 'aassign=' => 7,
1428               'multiply=' => 7, 'i_multiply=' => 7,
1429               'divide=' => 7, 'i_divide=' => 7,
1430               'modulo=' => 7, 'i_modulo=' => 7,
1431               'repeat=' => 7,
1432               'add=' => 7, 'i_add=' => 7,
1433               'subtract=' => 7, 'i_subtract=' => 7,
1434               'concat=' => 7,
1435               'left_shift=' => 7, 'right_shift=' => 7,
1436               'bit_and=' => 7,
1437               'bit_or=' => 7, 'bit_xor=' => 7,
1438               'andassign' => 7,
1439               'orassign' => 7,
1440              );
1441 }
1442
1443 sub deparse_binop_right {
1444     my $self = shift;
1445     my($op, $right, $prec) = @_;
1446     if ($right{assoc_class($op)} && $right{assoc_class($right)}
1447         and $right{assoc_class($op)} == $right{assoc_class($right)})
1448     {
1449         return $self->deparse($right, $prec - .00001);
1450     } else {
1451         return $self->deparse($right, $prec);
1452     }
1453 }
1454
1455 sub binop {
1456     my $self = shift;
1457     my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1458     my $left = $op->first;
1459     my $right = $op->last;
1460     my $eq = "";
1461     if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1462         $eq = "=";
1463         $prec = 7;
1464     }
1465     if ($flags & SWAP_CHILDREN) {
1466         ($left, $right) = ($right, $left);
1467     }
1468     $left = $self->deparse_binop_left($op, $left, $prec);
1469     $right = $self->deparse_binop_right($op, $right, $prec);
1470     return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1471 }
1472
1473 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1474 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1475 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18,  ASSIGN) }
1476 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1477 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1478 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1479 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1480 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1481 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1482 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1483 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1484
1485 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1486 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1487 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1488 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1489 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1490
1491 sub pp_eq { binop(@_, "==", 14) }
1492 sub pp_ne { binop(@_, "!=", 14) }
1493 sub pp_lt { binop(@_, "<", 15) }
1494 sub pp_gt { binop(@_, ">", 15) }
1495 sub pp_ge { binop(@_, ">=", 15) }
1496 sub pp_le { binop(@_, "<=", 15) }
1497 sub pp_ncmp { binop(@_, "<=>", 14) }
1498 sub pp_i_eq { binop(@_, "==", 14) }
1499 sub pp_i_ne { binop(@_, "!=", 14) }
1500 sub pp_i_lt { binop(@_, "<", 15) }
1501 sub pp_i_gt { binop(@_, ">", 15) }
1502 sub pp_i_ge { binop(@_, ">=", 15) }
1503 sub pp_i_le { binop(@_, "<=", 15) }
1504 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1505
1506 sub pp_seq { binop(@_, "eq", 14) }
1507 sub pp_sne { binop(@_, "ne", 14) }
1508 sub pp_slt { binop(@_, "lt", 15) }
1509 sub pp_sgt { binop(@_, "gt", 15) }
1510 sub pp_sge { binop(@_, "ge", 15) }
1511 sub pp_sle { binop(@_, "le", 15) }
1512 sub pp_scmp { binop(@_, "cmp", 14) }
1513
1514 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1515 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1516
1517 # `.' is special because concats-of-concats are optimized to save copying
1518 # by making all but the first concat stacked. The effect is as if the
1519 # programmer had written `($a . $b) .= $c', except legal.
1520 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1521 sub real_concat {
1522     my $self = shift;
1523     my($op, $cx) = @_;
1524     my $left = $op->first;
1525     my $right = $op->last;
1526     my $eq = "";
1527     my $prec = 18;
1528     if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1529         $eq = "=";
1530         $prec = 7;
1531     }
1532     $left = $self->deparse_binop_left($op, $left, $prec);
1533     $right = $self->deparse_binop_right($op, $right, $prec);
1534     return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1535 }
1536
1537 # `x' is weird when the left arg is a list
1538 sub pp_repeat {
1539     my $self = shift;
1540     my($op, $cx) = @_;
1541     my $left = $op->first;
1542     my $right = $op->last;
1543     my $eq = "";
1544     my $prec = 19;
1545     if ($op->flags & OPf_STACKED) {
1546         $eq = "=";
1547         $prec = 7;
1548     }
1549     if (null($right)) { # list repeat; count is inside left-side ex-list
1550         my $kid = $left->first->sibling; # skip pushmark
1551         my @exprs;
1552         for (; !null($kid->sibling); $kid = $kid->sibling) {
1553             push @exprs, $self->deparse($kid, 6);
1554         }
1555         $right = $kid;
1556         $left = "(" . join(", ", @exprs). ")";
1557     } else {
1558         $left = $self->deparse_binop_left($op, $left, $prec);
1559     }
1560     $right = $self->deparse_binop_right($op, $right, $prec);
1561     return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1562 }
1563
1564 sub range {
1565     my $self = shift;
1566     my ($op, $cx, $type) = @_;
1567     my $left = $op->first;
1568     my $right = $left->sibling;
1569     $left = $self->deparse($left, 9);
1570     $right = $self->deparse($right, 9);
1571     return $self->maybe_parens("$left $type $right", $cx, 9);
1572 }
1573
1574 sub pp_flop {
1575     my $self = shift;
1576     my($op, $cx) = @_;
1577     my $flip = $op->first;
1578     my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1579     return $self->range($flip->first, $cx, $type);
1580 }
1581
1582 # one-line while/until is handled in pp_leave
1583
1584 sub logop {
1585     my $self = shift;
1586     my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1587     my $left = $op->first;
1588     my $right = $op->first->sibling;
1589     if ($cx == 0 and is_scope($right) and $blockname
1590         and $self->{'expand'} < 7)
1591     { # if ($a) {$b}
1592         $left = $self->deparse($left, 1);
1593         $right = $self->deparse($right, 0);
1594         return "$blockname ($left) {\n\t$right\n\b}\cK";
1595     } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1596              and $self->{'expand'} < 7) { # $b if $a
1597         $right = $self->deparse($right, 1);
1598         $left = $self->deparse($left, 1);
1599         return "$right $blockname $left";
1600     } elsif ($cx > $lowprec and $highop) { # $a && $b
1601         $left = $self->deparse_binop_left($op, $left, $highprec);
1602         $right = $self->deparse_binop_right($op, $right, $highprec);
1603         return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1604     } else { # $a and $b
1605         $left = $self->deparse_binop_left($op, $left, $lowprec);
1606         $right = $self->deparse_binop_right($op, $right, $lowprec);
1607         return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1608     }
1609 }
1610
1611 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1612 sub pp_or  { logop(@_, "or",  2, "||", 10, "unless") }
1613
1614 # xor is syntactically a logop, but it's really a binop (contrary to
1615 # old versions of opcode.pl). Syntax is what matters here.
1616 sub pp_xor { logop(@_, "xor", 2, "",   0,  "") }
1617
1618 sub logassignop {
1619     my $self = shift;
1620     my ($op, $cx, $opname) = @_;
1621     my $left = $op->first;
1622     my $right = $op->first->sibling->first; # skip sassign
1623     $left = $self->deparse($left, 7);
1624     $right = $self->deparse($right, 7);
1625     return $self->maybe_parens("$left $opname $right", $cx, 7);
1626 }
1627
1628 sub pp_andassign { logassignop(@_, "&&=") }
1629 sub pp_orassign { logassignop(@_, "||=") }
1630
1631 sub listop {
1632     my $self = shift;
1633     my($op, $cx, $name) = @_;
1634     my(@exprs);
1635     my $parens = ($cx >= 5) || $self->{'parens'};
1636     my $kid = $op->first->sibling;
1637     return $name if null $kid;
1638     my $first = $self->deparse($kid, 6);
1639     $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1640     push @exprs, $first;
1641     $kid = $kid->sibling;
1642     for (; !null($kid); $kid = $kid->sibling) {
1643         push @exprs, $self->deparse($kid, 6);
1644     }
1645     if ($parens) {
1646         return "$name(" . join(", ", @exprs) . ")";
1647     } else {
1648         return "$name " . join(", ", @exprs);
1649     }
1650 }
1651
1652 sub pp_bless { listop(@_, "bless") }
1653 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1654 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1655 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1656 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1657 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1658 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1659 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1660 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1661 sub pp_unpack { listop(@_, "unpack") }
1662 sub pp_pack { listop(@_, "pack") }
1663 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1664 sub pp_splice { listop(@_, "splice") }
1665 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1666 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1667 sub pp_reverse { listop(@_, "reverse") }
1668 sub pp_warn { listop(@_, "warn") }
1669 sub pp_die { listop(@_, "die") }
1670 # Actually, return is exempt from the LLAFR (see examples in this very
1671 # module!), but for consistency's sake, ignore that fact
1672 sub pp_return { listop(@_, "return") }
1673 sub pp_open { listop(@_, "open") }
1674 sub pp_pipe_op { listop(@_, "pipe") }
1675 sub pp_tie { listop(@_, "tie") }
1676 sub pp_binmode { listop(@_, "binmode") }
1677 sub pp_dbmopen { listop(@_, "dbmopen") }
1678 sub pp_sselect { listop(@_, "select") }
1679 sub pp_select { listop(@_, "select") }
1680 sub pp_read { listop(@_, "read") }
1681 sub pp_sysopen { listop(@_, "sysopen") }
1682 sub pp_sysseek { listop(@_, "sysseek") }
1683 sub pp_sysread { listop(@_, "sysread") }
1684 sub pp_syswrite { listop(@_, "syswrite") }
1685 sub pp_send { listop(@_, "send") }
1686 sub pp_recv { listop(@_, "recv") }
1687 sub pp_seek { listop(@_, "seek") }
1688 sub pp_fcntl { listop(@_, "fcntl") }
1689 sub pp_ioctl { listop(@_, "ioctl") }
1690 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1691 sub pp_socket { listop(@_, "socket") }
1692 sub pp_sockpair { listop(@_, "sockpair") }
1693 sub pp_bind { listop(@_, "bind") }
1694 sub pp_connect { listop(@_, "connect") }
1695 sub pp_listen { listop(@_, "listen") }
1696 sub pp_accept { listop(@_, "accept") }
1697 sub pp_shutdown { listop(@_, "shutdown") }
1698 sub pp_gsockopt { listop(@_, "getsockopt") }
1699 sub pp_ssockopt { listop(@_, "setsockopt") }
1700 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1701 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1702 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1703 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1704 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1705 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1706 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1707 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1708 sub pp_open_dir { listop(@_, "opendir") }
1709 sub pp_seekdir { listop(@_, "seekdir") }
1710 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1711 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1712 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1713 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1714 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1715 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1716 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1717 sub pp_shmget { listop(@_, "shmget") }
1718 sub pp_shmctl { listop(@_, "shmctl") }
1719 sub pp_shmread { listop(@_, "shmread") }
1720 sub pp_shmwrite { listop(@_, "shmwrite") }
1721 sub pp_msgget { listop(@_, "msgget") }
1722 sub pp_msgctl { listop(@_, "msgctl") }
1723 sub pp_msgsnd { listop(@_, "msgsnd") }
1724 sub pp_msgrcv { listop(@_, "msgrcv") }
1725 sub pp_semget { listop(@_, "semget") }
1726 sub pp_semctl { listop(@_, "semctl") }
1727 sub pp_semop { listop(@_, "semop") }
1728 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1729 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1730 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1731 sub pp_gsbyname { listop(@_, "getservbyname") }
1732 sub pp_gsbyport { listop(@_, "getservbyport") }
1733 sub pp_syscall { listop(@_, "syscall") }
1734
1735 sub pp_glob {
1736     my $self = shift;
1737     my($op, $cx) = @_;
1738     my $text = $self->dq($op->first->sibling);  # skip pushmark
1739     if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1740         or $text =~ /[<>]/) {
1741         return 'glob(' . single_delim('qq', '"', $text) . ')';
1742     } else {
1743         return '<' . $text . '>';
1744     }
1745 }
1746
1747 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1748 # be a filehandle. This could probably be better fixed in the core
1749 # by moving the GV lookup into ck_truc.
1750
1751 sub pp_truncate {
1752     my $self = shift;
1753     my($op, $cx) = @_;
1754     my(@exprs);
1755     my $parens = ($cx >= 5) || $self->{'parens'};
1756     my $kid = $op->first->sibling;
1757     my $fh;
1758     if ($op->flags & OPf_SPECIAL) {
1759         # $kid is an OP_CONST
1760         $fh = $self->const_sv($kid)->PV;
1761     } else {
1762         $fh = $self->deparse($kid, 6);
1763         $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1764     }
1765     my $len = $self->deparse($kid->sibling, 6);
1766     if ($parens) {
1767         return "truncate($fh, $len)";
1768     } else {
1769         return "truncate $fh, $len";
1770     }
1771 }
1772
1773 sub indirop {
1774     my $self = shift;
1775     my($op, $cx, $name) = @_;
1776     my($expr, @exprs);
1777     my $kid = $op->first->sibling;
1778     my $indir = "";
1779     if ($op->flags & OPf_STACKED) {
1780         $indir = $kid;
1781         $indir = $indir->first; # skip rv2gv
1782         if (is_scope($indir)) {
1783             $indir = "{" . $self->deparse($indir, 0) . "}";
1784         } else {
1785             $indir = $self->deparse($indir, 24);
1786         }
1787         $indir = $indir . " ";
1788         $kid = $kid->sibling;
1789     }
1790     for (; !null($kid); $kid = $kid->sibling) {
1791         $expr = $self->deparse($kid, 6);
1792         push @exprs, $expr;
1793     }
1794     return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
1795                                     $cx, 5);
1796 }
1797
1798 sub pp_prtf { indirop(@_, "printf") }
1799 sub pp_print { indirop(@_, "print") }
1800 sub pp_sort { indirop(@_, "sort") }
1801
1802 sub mapop {
1803     my $self = shift;
1804     my($op, $cx, $name) = @_;
1805     my($expr, @exprs);
1806     my $kid = $op->first; # this is the (map|grep)start
1807     $kid = $kid->first->sibling; # skip a pushmark
1808     my $code = $kid->first; # skip a null
1809     if (is_scope $code) {
1810         $code = "{" . $self->deparse($code, 0) . "} ";
1811     } else {
1812         $code = $self->deparse($code, 24) . ", ";
1813     }
1814     $kid = $kid->sibling;
1815     for (; !null($kid); $kid = $kid->sibling) {
1816         $expr = $self->deparse($kid, 6);
1817         push @exprs, $expr if $expr;
1818     }
1819     return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1820 }
1821
1822 sub pp_mapwhile { mapop(@_, "map") }
1823 sub pp_grepwhile { mapop(@_, "grep") }
1824
1825 sub pp_list {
1826     my $self = shift;
1827     my($op, $cx) = @_;
1828     my($expr, @exprs);
1829     my $kid = $op->first->sibling; # skip pushmark
1830     my $lop;
1831     my $local = "either"; # could be local(...) or my(...)
1832     for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1833         # This assumes that no other private flags equal 128, and that
1834         # OPs that store things other than flags in their op_private,
1835         # like OP_AELEMFAST, won't be immediate children of a list.
1836         unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
1837         {
1838             $local = ""; # or not
1839             last;
1840         }
1841         if ($lop->name =~ /^pad[ash]v$/) { # my()
1842             ($local = "", last) if $local eq "local";
1843             $local = "my";
1844         } elsif ($lop->name ne "undef") { # local()
1845             ($local = "", last) if $local eq "my";
1846             $local = "local";
1847         }
1848     }
1849     $local = "" if $local eq "either"; # no point if it's all undefs
1850     return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1851     for (; !null($kid); $kid = $kid->sibling) {
1852         if ($local) {
1853             if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
1854                 $lop = $kid->first;
1855             } else {
1856                 $lop = $kid;
1857             }
1858             $self->{'avoid_local'}{$$lop}++;
1859             $expr = $self->deparse($kid, 6);
1860             delete $self->{'avoid_local'}{$$lop};
1861         } else {
1862             $expr = $self->deparse($kid, 6);
1863         }
1864         push @exprs, $expr;
1865     }
1866     if ($local) {
1867         return "$local(" . join(", ", @exprs) . ")";
1868     } else {
1869         return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1870     }
1871 }
1872
1873 sub is_ifelse_cont {
1874     my $op = shift;
1875     return ($op->name eq "null" and class($op) eq "UNOP"
1876             and $op->first->name =~ /^(and|cond_expr)$/
1877             and is_scope($op->first->first->sibling));
1878 }
1879
1880 sub pp_cond_expr {
1881     my $self = shift;
1882     my($op, $cx) = @_;
1883     my $cond = $op->first;
1884     my $true = $cond->sibling;
1885     my $false = $true->sibling;
1886     my $cuddle = $self->{'cuddle'};
1887     unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
1888             (is_scope($false) || is_ifelse_cont($false))
1889             and $self->{'expand'} < 7) {
1890         $cond = $self->deparse($cond, 8);
1891         $true = $self->deparse($true, 8);
1892         $false = $self->deparse($false, 8);
1893         return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1894     }
1895
1896     $cond = $self->deparse($cond, 1);
1897     $true = $self->deparse($true, 0);
1898     my $head = "if ($cond) {\n\t$true\n\b}";
1899     my @elsifs;
1900     while (!null($false) and is_ifelse_cont($false)) {
1901         my $newop = $false->first;
1902         my $newcond = $newop->first;
1903         my $newtrue = $newcond->sibling;
1904         $false = $newtrue->sibling; # last in chain is OP_AND => no else
1905         $newcond = $self->deparse($newcond, 1);
1906         $newtrue = $self->deparse($newtrue, 0);
1907         push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1908     }
1909     if (!null($false)) {
1910         $false = $cuddle . "else {\n\t" .
1911           $self->deparse($false, 0) . "\n\b}\cK";
1912     } else {
1913         $false = "\cK";
1914     }
1915     return $head . join($cuddle, "", @elsifs) . $false;
1916 }
1917
1918 sub loop_common {
1919     my $self = shift;
1920     my($op, $cx, $init) = @_;
1921     my $enter = $op->first;
1922     my $kid = $enter->sibling;
1923     local(@$self{qw'curstash warnings hints'})
1924                 = @$self{qw'curstash warnings hints'};
1925     my $head = "";
1926     my $bare = 0;
1927     my $body;
1928     my $cond = undef;
1929     if ($kid->name eq "lineseq") { # bare or infinite loop
1930         if (is_state $kid->last) { # infinite
1931             $head = "for (;;) "; # shorter than while (1)
1932             $cond = "";
1933         } else {
1934             $bare = 1;
1935         }
1936         $body = $kid;
1937     } elsif ($enter->name eq "enteriter") { # foreach
1938         my $ary = $enter->first->sibling; # first was pushmark
1939         my $var = $ary->sibling;
1940         if ($enter->flags & OPf_STACKED
1941             and not null $ary->first->sibling->sibling)
1942         {
1943             $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1944               $self->deparse($ary->first->sibling->sibling, 9);
1945         } else {
1946             $ary = $self->deparse($ary, 1);
1947         }
1948         if (null $var) {
1949             if ($enter->flags & OPf_SPECIAL) { # thread special var
1950                 $var = $self->pp_threadsv($enter, 1);
1951             } else { # regular my() variable
1952                 $var = $self->pp_padsv($enter, 1);
1953                 if ($self->padname_sv($enter->targ)->IVX ==
1954                     $kid->first->first->sibling->last->cop_seq)
1955                 {
1956                     # If the scope of this variable closes at the last
1957                     # statement of the loop, it must have been
1958                     # declared here.
1959                     $var = "my " . $var;
1960                 }
1961             }
1962         } elsif ($var->name eq "rv2gv") {
1963             $var = $self->pp_rv2sv($var, 1);
1964         } elsif ($var->name eq "gv") {
1965             $var = "\$" . $self->deparse($var, 1);
1966         }
1967         $head = "foreach $var ($ary) ";
1968         $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1969     } elsif ($kid->name eq "null") { # while/until
1970         $kid = $kid->first;
1971         my $name = {"and" => "while", "or" => "until"}->{$kid->name};
1972         $cond = $self->deparse($kid->first, 1);
1973         $head = "$name ($cond) ";
1974         $body = $kid->first->sibling;
1975     } elsif ($kid->name eq "stub") { # bare and empty
1976         return "{;}"; # {} could be a hashref
1977     }
1978     # If there isn't a continue block, then the next pointer for the loop
1979     # will point to the unstack, which is kid's penultimate child, except
1980     # in a bare loop, when it will point to the leaveloop. When neither of
1981     # these conditions hold, then the third-to-last child in the continue
1982     # block (or the last in a bare loop).
1983     my $cont_start = $enter->nextop;
1984     my $cont;
1985     if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
1986         if ($bare) {
1987             $cont = $body->last;
1988         } else {
1989             $cont = $body->first;
1990             while (!null($cont->sibling->sibling->sibling)) {
1991                 $cont = $cont->sibling;
1992             }
1993         }
1994         my $state = $body->first;
1995         my $cuddle = $self->{'cuddle'};
1996         my @states;
1997         for (; $$state != $$cont; $state = $state->sibling) {
1998             push @states, $state;
1999         }
2000         $body = $self->lineseq(@states);
2001         if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2002             $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2003             $cont = "\cK";
2004         } else {
2005             $cont = $cuddle . "continue {\n\t" .
2006               $self->deparse($cont, 0) . "\n\b}\cK";
2007         }
2008     } else {
2009         return "" if !defined $body;
2010         $cont = "\cK";
2011         $body = $self->deparse($body, 0);
2012     }
2013     return $head . "{\n\t" . $body . "\n\b}" . $cont;
2014 }
2015
2016 sub pp_leaveloop { loop_common(@_, "") }
2017
2018 sub for_loop {
2019     my $self = shift;
2020     my($op, $cx) = @_;
2021     my $init = $self->deparse($op, 1);
2022     return $self->loop_common($op->sibling, $cx, $init);
2023 }
2024
2025 sub pp_leavetry {
2026     my $self = shift;
2027     return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2028 }
2029
2030 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2031 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2032
2033 sub pp_null {
2034     my $self = shift;
2035     my($op, $cx) = @_;
2036     if (class($op) eq "OP") {
2037         # old value is lost
2038         return $self->{'ex_const'} if $op->targ == OP_CONST;
2039     } elsif ($op->first->name eq "pushmark") {
2040         return $self->pp_list($op, $cx);
2041     } elsif ($op->first->name eq "enter") {
2042         return $self->pp_leave($op, $cx);
2043     } elsif ($op->targ == OP_STRINGIFY) {
2044         return $self->dquote($op, $cx);
2045     } elsif (!null($op->first->sibling) and
2046              $op->first->sibling->name eq "readline" and
2047              $op->first->sibling->flags & OPf_STACKED) {
2048         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2049                                    . $self->deparse($op->first->sibling, 7),
2050                                    $cx, 7);
2051     } elsif (!null($op->first->sibling) and
2052              $op->first->sibling->name eq "trans" and
2053              $op->first->sibling->flags & OPf_STACKED) {
2054         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2055                                    . $self->deparse($op->first->sibling, 20),
2056                                    $cx, 20);
2057     } else {
2058         return $self->deparse($op->first, $cx);
2059     }
2060 }
2061
2062 sub padname {
2063     my $self = shift;
2064     my $targ = shift;
2065     return $self->padname_sv($targ)->PVX;
2066 }
2067
2068 sub padany {
2069     my $self = shift;
2070     my $op = shift;
2071     return substr($self->padname($op->targ), 1); # skip $/@/%
2072 }
2073
2074 sub pp_padsv {
2075     my $self = shift;
2076     my($op, $cx) = @_;
2077     return $self->maybe_my($op, $cx, $self->padname($op->targ));
2078 }
2079
2080 sub pp_padav { pp_padsv(@_) }
2081 sub pp_padhv { pp_padsv(@_) }
2082
2083 my @threadsv_names;
2084
2085 BEGIN {
2086     @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2087                        "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2088                        "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2089                        "!", "@");
2090 }
2091
2092 sub pp_threadsv {
2093     my $self = shift;
2094     my($op, $cx) = @_;
2095     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
2096 }
2097
2098 sub gv_or_padgv {
2099     my $self = shift;
2100     my $op = shift;
2101     if (class($op) eq "PADOP") {
2102         return $self->padval($op->padix);
2103     } else { # class($op) eq "SVOP"
2104         return $op->gv;
2105     }
2106 }
2107
2108 sub pp_gvsv {
2109     my $self = shift;
2110     my($op, $cx) = @_;
2111     my $gv = $self->gv_or_padgv($op);
2112     return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
2113 }
2114
2115 sub pp_gv {
2116     my $self = shift;
2117     my($op, $cx) = @_;
2118     my $gv = $self->gv_or_padgv($op);
2119     return $self->gv_name($gv);
2120 }
2121
2122 sub pp_aelemfast {
2123     my $self = shift;
2124     my($op, $cx) = @_;
2125     my $gv = $self->gv_or_padgv($op);
2126     return "\$" . $self->gv_name($gv) . "[" .
2127                   ($op->private + $self->{'arybase'}) . "]";
2128 }
2129
2130 sub rv2x {
2131     my $self = shift;
2132     my($op, $cx, $type) = @_;
2133     my $kid = $op->first;
2134     my $str = $self->deparse($kid, 0);
2135     return $type . (is_scalar($kid) ? $str : "{$str}");
2136 }
2137
2138 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2139 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2140 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2141
2142 # skip rv2av
2143 sub pp_av2arylen {
2144     my $self = shift;
2145     my($op, $cx) = @_;
2146     if ($op->first->name eq "padav") {
2147         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2148     } else {
2149         return $self->maybe_local($op, $cx,
2150                                   $self->rv2x($op->first, $cx, '$#'));
2151     }
2152 }
2153
2154 # skip down to the old, ex-rv2cv
2155 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
2156
2157 sub pp_rv2av {
2158     my $self = shift;
2159     my($op, $cx) = @_;
2160     my $kid = $op->first;
2161     if ($kid->name eq "const") { # constant list
2162         my $av = $self->const_sv($kid);
2163         return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2164     } else {
2165         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2166     }
2167  }
2168
2169 sub is_subscriptable {
2170     my $op = shift;
2171     if ($op->name =~ /^[ahg]elem/) {
2172         return 1;
2173     } elsif ($op->name eq "entersub") {
2174         my $kid = $op->first;
2175         return 0 unless null $kid->sibling;
2176         $kid = $kid->first;
2177         $kid = $kid->sibling until null $kid->sibling;
2178         return 0 if is_scope($kid);
2179         $kid = $kid->first;
2180         return 0 if $kid->name eq "gv";
2181         return 0 if is_scalar($kid);
2182         return is_subscriptable($kid);
2183     } else {
2184         return 0;
2185     }
2186 }
2187
2188 sub elem {
2189     my $self = shift;
2190     my ($op, $cx, $left, $right, $padname) = @_;
2191     my($array, $idx) = ($op->first, $op->first->sibling);
2192     unless ($array->name eq $padname) { # Maybe this has been fixed
2193         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2194     }
2195     if ($array->name eq $padname) {
2196         $array = $self->padany($array);
2197     } elsif (is_scope($array)) { # ${expr}[0]
2198         $array = "{" . $self->deparse($array, 0) . "}";
2199     } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2200         $array = $self->deparse($array, 24);
2201     } else {
2202         # $x[20][3]{hi} or expr->[20]
2203         my $arrow = is_subscriptable($array) ? "" : "->";
2204         return $self->deparse($array, 24) . $arrow .
2205             $left . $self->deparse($idx, 1) . $right;
2206     }
2207     $idx = $self->deparse($idx, 1);
2208
2209     # Outer parens in an array index will confuse perl
2210     # if we're interpolating in a regular expression, i.e.
2211     # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2212     #
2213     # If $self->{parens}, then an initial '(' will
2214     # definitely be paired with a final ')'. If
2215     # !$self->{parens}, the misleading parens won't
2216     # have been added in the first place.
2217     #
2218     # [You might think that we could get "(...)...(...)"
2219     # where the initial and final parens do not match
2220     # each other. But we can't, because the above would
2221     # only happen if there's an infix binop between the
2222     # two pairs of parens, and *that* means that the whole
2223     # expression would be parenthesized as well.]
2224     #
2225     $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2226
2227     return "\$" . $array . $left . $idx . $right;
2228 }
2229
2230 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2231 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2232
2233 sub pp_gelem {
2234     my $self = shift;
2235     my($op, $cx) = @_;
2236     my($glob, $part) = ($op->first, $op->last);
2237     $glob = $glob->first; # skip rv2gv
2238     $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2239     my $scope = is_scope($glob);
2240     $glob = $self->deparse($glob, 0);
2241     $part = $self->deparse($part, 1);
2242     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2243 }
2244
2245 sub slice {
2246     my $self = shift;
2247     my ($op, $cx, $left, $right, $regname, $padname) = @_;
2248     my $last;
2249     my(@elems, $kid, $array, $list);
2250     if (class($op) eq "LISTOP") {
2251         $last = $op->last;
2252     } else { # ex-hslice inside delete()
2253         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2254         $last = $kid;
2255     }
2256     $array = $last;
2257     $array = $array->first
2258         if $array->name eq $regname or $array->name eq "null";
2259     if (is_scope($array)) {
2260         $array = "{" . $self->deparse($array, 0) . "}";
2261     } elsif ($array->name eq $padname) {
2262         $array = $self->padany($array);
2263     } else {
2264         $array = $self->deparse($array, 24);
2265     }
2266     $kid = $op->first->sibling; # skip pushmark
2267     if ($kid->name eq "list") {
2268         $kid = $kid->first->sibling; # skip list, pushmark
2269         for (; !null $kid; $kid = $kid->sibling) {
2270             push @elems, $self->deparse($kid, 6);
2271         }
2272         $list = join(", ", @elems);
2273     } else {
2274         $list = $self->deparse($kid, 1);
2275     }
2276     return "\@" . $array . $left . $list . $right;
2277 }
2278
2279 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2280 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2281
2282 sub pp_lslice {
2283     my $self = shift;
2284     my($op, $cx) = @_;
2285     my $idx = $op->first;
2286     my $list = $op->last;
2287     my(@elems, $kid);
2288     $list = $self->deparse($list, 1);
2289     $idx = $self->deparse($idx, 1);
2290     return "($list)" . "[$idx]";
2291 }
2292
2293 sub want_scalar {
2294     my $op = shift;
2295     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2296 }
2297
2298 sub want_list {
2299     my $op = shift;
2300     return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2301 }
2302
2303 sub method {
2304     my $self = shift;
2305     my($op, $cx) = @_;
2306     my $kid = $op->first->sibling; # skip pushmark
2307     my($meth, $obj, @exprs);
2308     if ($kid->name eq "list" and want_list $kid) {
2309         # When an indirect object isn't a bareword but the args are in
2310         # parens, the parens aren't part of the method syntax (the LLAFR
2311         # doesn't apply), but they make a list with OPf_PARENS set that
2312         # doesn't get flattened by the append_elem that adds the method,
2313         # making a (object, arg1, arg2, ...) list where the object
2314         # usually is. This can be distinguished from
2315         # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2316         # object) because in the later the list is in scalar context
2317         # as the left side of -> always is, while in the former
2318         # the list is in list context as method arguments always are.
2319         # (Good thing there aren't method prototypes!)
2320         $meth = $kid->sibling;
2321         $kid = $kid->first->sibling; # skip pushmark
2322         $obj = $kid;
2323         $kid = $kid->sibling;
2324         for (; not null $kid; $kid = $kid->sibling) {
2325             push @exprs, $self->deparse($kid, 6);
2326         }
2327     } else {
2328         $obj = $kid;
2329         $kid = $kid->sibling;
2330         for (; not null $kid->sibling; $kid = $kid->sibling) {
2331             push @exprs, $self->deparse($kid, 6);
2332         }
2333         $meth = $kid;
2334     }
2335     $obj = $self->deparse($obj, 24);
2336     if ($meth->name eq "method_named") {
2337         $meth = $self->const_sv($meth)->PV;
2338     } else {
2339         $meth = $meth->first;
2340         if ($meth->name eq "const") {
2341             # As of 5.005_58, this case is probably obsoleted by the
2342             # method_named case above
2343             $meth = $self->const_sv($meth)->PV; # needs to be bare
2344         } else {
2345             $meth = $self->deparse($meth, 1);
2346         }
2347     }
2348     my $args = join(", ", @exprs);
2349     $kid = $obj . "->" . $meth;
2350     if ($args) {
2351         return $kid . "(" . $args . ")"; # parens mandatory
2352     } else {
2353         return $kid;
2354     }
2355 }
2356
2357 # returns "&" if the prototype doesn't match the args,
2358 # or ("", $args_after_prototype_demunging) if it does.
2359 sub check_proto {
2360     my $self = shift;
2361     my($proto, @args) = @_;
2362     my($arg, $real);
2363     my $doneok = 0;
2364     my @reals;
2365     # An unbackslashed @ or % gobbles up the rest of the args
2366     $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2367     while ($proto) {
2368         $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2369         my $chr = $1;
2370         if ($chr eq "") {
2371             return "&" if @args;
2372         } elsif ($chr eq ";") {
2373             $doneok = 1;
2374         } elsif ($chr eq "@" or $chr eq "%") {
2375             push @reals, map($self->deparse($_, 6), @args);
2376             @args = ();
2377         } else {
2378             $arg = shift @args;
2379             last unless $arg;
2380             if ($chr eq "\$") {
2381                 if (want_scalar $arg) {
2382                     push @reals, $self->deparse($arg, 6);
2383                 } else {
2384                     return "&";
2385                 }
2386             } elsif ($chr eq "&") {
2387                 if ($arg->name =~ /^(s?refgen|undef)$/) {
2388                     push @reals, $self->deparse($arg, 6);
2389                 } else {
2390                     return "&";
2391                 }
2392             } elsif ($chr eq "*") {
2393                 if ($arg->name =~ /^s?refgen$/
2394                     and $arg->first->first->name eq "rv2gv")
2395                   {
2396                       $real = $arg->first->first; # skip refgen, null
2397                       if ($real->first->name eq "gv") {
2398                           push @reals, $self->deparse($real, 6);
2399                       } else {
2400                           push @reals, $self->deparse($real->first, 6);
2401                       }
2402                   } else {
2403                       return "&";
2404                   }
2405             } elsif (substr($chr, 0, 1) eq "\\") {
2406                 $chr = substr($chr, 1);
2407                 if ($arg->name =~ /^s?refgen$/ and
2408                     !null($real = $arg->first) and
2409                     ($chr eq "\$" && is_scalar($real->first)
2410                      or ($chr eq "\@"
2411                          && $real->first->sibling->name
2412                          =~ /^(rv2|pad)av$/)
2413                      or ($chr eq "%"
2414                          && $real->first->sibling->name
2415                          =~ /^(rv2|pad)hv$/)
2416                      #or ($chr eq "&" # This doesn't work
2417                      #   && $real->first->name eq "rv2cv")
2418                      or ($chr eq "*"
2419                          && $real->first->name eq "rv2gv")))
2420                   {
2421                       push @reals, $self->deparse($real, 6);
2422                   } else {
2423                       return "&";
2424                   }
2425             }
2426        }
2427     }
2428     return "&" if $proto and !$doneok; # too few args and no `;'
2429     return "&" if @args;               # too many args
2430     return ("", join ", ", @reals);
2431 }
2432
2433 sub pp_entersub {
2434     my $self = shift;
2435     my($op, $cx) = @_;
2436     return $self->method($op, $cx) unless null $op->first->sibling;
2437     my $prefix = "";
2438     my $amper = "";
2439     my($kid, @exprs);
2440     if ($op->flags & OPf_SPECIAL) {
2441         $prefix = "do ";
2442     } elsif ($op->private & OPpENTERSUB_AMPER) {
2443         $amper = "&";
2444     }
2445     $kid = $op->first;
2446     $kid = $kid->first->sibling; # skip ex-list, pushmark
2447     for (; not null $kid->sibling; $kid = $kid->sibling) {
2448         push @exprs, $kid;
2449     }
2450     my $simple = 0;
2451     my $proto = undef;
2452     if (is_scope($kid)) {
2453         $amper = "&";
2454         $kid = "{" . $self->deparse($kid, 0) . "}";
2455     } elsif ($kid->first->name eq "gv") {
2456         my $gv = $self->gv_or_padgv($kid->first);
2457         if (class($gv->CV) ne "SPECIAL") {
2458             $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2459         }
2460         $simple = 1; # only calls of named functions can be prototyped
2461         $kid = $self->deparse($kid, 24);
2462     } elsif (is_scalar $kid->first) {
2463         $amper = "&";
2464         $kid = $self->deparse($kid, 24);
2465     } else {
2466         $prefix = "";
2467         my $arrow = is_subscriptable($kid->first) ? "" : "->";
2468         $kid = $self->deparse($kid, 24) . $arrow;
2469     }
2470
2471     # Doesn't matter how many prototypes there are, if
2472     # they haven't happened yet!
2473     my $declared = exists $self->{'subs_declared'}{$kid};
2474
2475     my $args;
2476     if ($declared and defined $proto and not $amper) {
2477         ($amper, $args) = $self->check_proto($proto, @exprs);
2478         if ($amper eq "&") {
2479             $args = join(", ", map($self->deparse($_, 6), @exprs));
2480         }
2481     } else {
2482         $args = join(", ", map($self->deparse($_, 6), @exprs));
2483     }
2484     if ($prefix or $amper) {
2485         if ($op->flags & OPf_STACKED) {
2486             return $prefix . $amper . $kid . "(" . $args . ")";
2487         } else {
2488             return $prefix . $amper. $kid;
2489         }
2490     } else {
2491         if (!$declared) {
2492             return "$kid(" . $args . ")";
2493         } elsif (defined $proto and $proto eq "") {
2494             return $kid;
2495         } elsif (defined $proto and $proto eq "\$") {
2496             return $self->maybe_parens_func($kid, $args, $cx, 16);
2497         } elsif (defined($proto) && $proto or $simple) {
2498             return $self->maybe_parens_func($kid, $args, $cx, 5);
2499         } else {
2500             return "$kid(" . $args . ")";
2501         }
2502     }
2503 }
2504
2505 sub pp_enterwrite { unop(@_, "write") }
2506
2507 # escape things that cause interpolation in double quotes,
2508 # but not character escapes
2509 sub uninterp {
2510     my($str) = @_;
2511     $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2512     return $str;
2513 }
2514
2515 # the same, but treat $|, $), and $ at the end of the string differently
2516 sub re_uninterp {
2517     my($str) = @_;
2518     $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2519     $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2520     return $str;
2521 }
2522
2523 # character escapes, but not delimiters that might need to be escaped
2524 sub escape_str { # ASCII, UTF8
2525     my($str) = @_;
2526     $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
2527     $str =~ s/\a/\\a/g;
2528 #    $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2529     $str =~ s/\t/\\t/g;
2530     $str =~ s/\n/\\n/g;
2531     $str =~ s/\e/\\e/g;
2532     $str =~ s/\f/\\f/g;
2533     $str =~ s/\r/\\r/g;
2534     $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2535     $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2536     return $str;
2537 }
2538
2539 # Don't do this for regexen
2540 sub unback {
2541     my($str) = @_;
2542     $str =~ s/\\/\\\\/g;
2543     return $str;
2544 }
2545
2546 # Remove backslashes which precede literal control characters,
2547 # to avoid creating ambiguity when we escape the latter.
2548 sub re_unback {
2549     my($str) = @_;
2550
2551     # the insane complexity here is due to the behaviour of "\c\"
2552     $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
2553     return $str;
2554 }
2555
2556 sub balanced_delim {
2557     my($str) = @_;
2558     my @str = split //, $str;
2559     my($ar, $open, $close, $fail, $c, $cnt);
2560     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2561         ($open, $close) = @$ar;
2562         $fail = 0; $cnt = 0;
2563         for $c (@str) {
2564             if ($c eq $open) {
2565                 $cnt++;
2566             } elsif ($c eq $close) {
2567                 $cnt--;
2568                 if ($cnt < 0) {
2569                     # qq()() isn't ")("
2570                     $fail = 1;
2571                     last;
2572                 }
2573             }
2574         }
2575         $fail = 1 if $cnt != 0;
2576         return ($open, "$open$str$close") if not $fail;
2577     }
2578     return ("", $str);
2579 }
2580
2581 sub single_delim {
2582     my($q, $default, $str) = @_;
2583     return "$default$str$default" if $default and index($str, $default) == -1;
2584     my($succeed, $delim);
2585     ($succeed, $str) = balanced_delim($str);
2586     return "$q$str" if $succeed;
2587     for $delim ('/', '"', '#') {
2588         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2589     }
2590     if ($default) {
2591         $str =~ s/$default/\\$default/g;
2592         return "$default$str$default";
2593     } else {
2594         $str =~ s[/][\\/]g;
2595         return "$q/$str/";
2596     }
2597 }
2598
2599 sub const {
2600     my $sv = shift;
2601     if (class($sv) eq "SPECIAL") {
2602         return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2603     } elsif (class($sv) eq "NULL") {
2604        return 'undef';
2605     } elsif ($sv->FLAGS & SVf_IOK) {
2606         return $sv->int_value;
2607     } elsif ($sv->FLAGS & SVf_NOK) {
2608         return $sv->NV;
2609     } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
2610         return "\\(" . const($sv->RV) . ")"; # constant folded
2611     } else {
2612         my $str = $sv->PV;
2613         if ($str =~ /[^ -~]/) { # ASCII for non-printing
2614             return single_delim("qq", '"', uninterp escape_str unback $str);
2615         } else {
2616             return single_delim("q", "'", unback $str);
2617         }
2618     }
2619 }
2620
2621 sub const_sv {
2622     my $self = shift;
2623     my $op = shift;
2624     my $sv = $op->sv;
2625     # the constant could be in the pad (under useithreads)
2626     $sv = $self->padval($op->targ) unless $$sv;
2627     return $sv;
2628 }
2629
2630 sub pp_const {
2631     my $self = shift;
2632     my($op, $cx) = @_;
2633 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2634 #       return $self->const_sv($op)->PV;
2635 #    }
2636     my $sv = $self->const_sv($op);
2637 #    return const($sv);
2638     if ($op->private & OPpCONST_ARYBASE) {
2639         return '$[';
2640     }
2641     my $c = const $sv;
2642     return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
2643 }
2644
2645 sub dq {
2646     my $self = shift;
2647     my $op = shift;
2648     my $type = $op->name;
2649     if ($type eq "const") {
2650         return uninterp(escape_str(unback($self->const_sv($op)->PV)));
2651     } elsif ($type eq "concat") {
2652         my $first = $self->dq($op->first);
2653         my $last  = $self->dq($op->last);
2654         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2655         if ($last =~ /^[{\[\w]/) {
2656             $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2657         }
2658         return $first . $last;
2659     } elsif ($type eq "uc") {
2660         return '\U' . $self->dq($op->first->sibling) . '\E';
2661     } elsif ($type eq "lc") {
2662         return '\L' . $self->dq($op->first->sibling) . '\E';
2663     } elsif ($type eq "ucfirst") {
2664         return '\u' . $self->dq($op->first->sibling);
2665     } elsif ($type eq "lcfirst") {
2666         return '\l' . $self->dq($op->first->sibling);
2667     } elsif ($type eq "quotemeta") {
2668         return '\Q' . $self->dq($op->first->sibling) . '\E';
2669     } elsif ($type eq "join") {
2670         return $self->deparse($op->last, 26); # was join($", @ary)
2671     } else {
2672         return $self->deparse($op, 26);
2673     }
2674 }
2675
2676 sub pp_backtick {
2677     my $self = shift;
2678     my($op, $cx) = @_;
2679     # skip pushmark
2680     return single_delim("qx", '`', $self->dq($op->first->sibling));
2681 }
2682
2683 sub dquote {
2684     my $self = shift;
2685     my($op, $cx) = @_;
2686     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2687     return $self->deparse($kid, $cx) if $self->{'unquote'};
2688     $self->maybe_targmy($kid, $cx,
2689                         sub {single_delim("qq", '"', $self->dq($_[1]))});
2690 }
2691
2692 # OP_STRINGIFY is a listop, but it only ever has one arg
2693 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2694
2695 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2696 # note that tr(from)/to/ is OK, but not tr/from/(to)
2697 sub double_delim {
2698     my($from, $to) = @_;
2699     my($succeed, $delim);
2700     if ($from !~ m[/] and $to !~ m[/]) {
2701         return "/$from/$to/";
2702     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2703         if (($succeed, $to) = balanced_delim($to) and $succeed) {
2704             return "$from$to";
2705         } else {
2706             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2707                 return "$from$delim$to$delim" if index($to, $delim) == -1;
2708             }
2709             $to =~ s[/][\\/]g;
2710             return "$from/$to/";
2711         }
2712     } else {
2713         for $delim ('/', '"', '#') { # note no '
2714             return "$delim$from$delim$to$delim"
2715                 if index($to . $from, $delim) == -1;
2716         }
2717         $from =~ s[/][\\/]g;
2718         $to =~ s[/][\\/]g;
2719         return "/$from/$to/";
2720     }
2721 }
2722
2723 sub pchr { # ASCII
2724     my($n) = @_;
2725     if ($n == ord '\\') {
2726         return '\\\\';
2727     } elsif ($n >= ord(' ') and $n <= ord('~')) {
2728         return chr($n);
2729     } elsif ($n == ord "\a") {
2730         return '\\a';
2731     } elsif ($n == ord "\b") {
2732         return '\\b';
2733     } elsif ($n == ord "\t") {
2734         return '\\t';
2735     } elsif ($n == ord "\n") {
2736         return '\\n';
2737     } elsif ($n == ord "\e") {
2738         return '\\e';
2739     } elsif ($n == ord "\f") {
2740         return '\\f';
2741     } elsif ($n == ord "\r") {
2742         return '\\r';
2743     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2744         return '\\c' . chr(ord("@") + $n);
2745     } else {
2746 #       return '\x' . sprintf("%02x", $n);
2747         return '\\' . sprintf("%03o", $n);
2748     }
2749 }
2750
2751 sub collapse {
2752     my(@chars) = @_;
2753     my($str, $c, $tr) = ("");
2754     for ($c = 0; $c < @chars; $c++) {
2755         $tr = $chars[$c];
2756         $str .= pchr($tr);
2757         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2758             $chars[$c + 2] == $tr + 2)
2759         {
2760             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2761               {}
2762             $str .= "-";
2763             $str .= pchr($chars[$c]);
2764         }
2765     }
2766     return $str;
2767 }
2768
2769 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2770 # and backslashes.
2771
2772 sub tr_decode_byte {
2773     my($table, $flags) = @_;
2774     my(@table) = unpack("s256", $table);
2775     my($c, $tr, @from, @to, @delfrom, $delhyphen);
2776     if ($table[ord "-"] != -1 and
2777         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2778     {
2779         $tr = $table[ord "-"];
2780         $table[ord "-"] = -1;
2781         if ($tr >= 0) {
2782             @from = ord("-");
2783             @to = $tr;
2784         } else { # -2 ==> delete
2785             $delhyphen = 1;
2786         }
2787     }
2788     for ($c = 0; $c < 256; $c++) {
2789         $tr = $table[$c];
2790         if ($tr >= 0) {
2791             push @from, $c; push @to, $tr;
2792         } elsif ($tr == -2) {
2793             push @delfrom, $c;
2794         }
2795     }
2796     @from = (@from, @delfrom);
2797     if ($flags & OPpTRANS_COMPLEMENT) {
2798         my @newfrom = ();
2799         my %from;
2800         @from{@from} = (1) x @from;
2801         for ($c = 0; $c < 256; $c++) {
2802             push @newfrom, $c unless $from{$c};
2803         }
2804         @from = @newfrom;
2805     }
2806     unless ($flags & OPpTRANS_DELETE || !@to) {
2807         pop @to while $#to and $to[$#to] == $to[$#to -1];
2808     }
2809     my($from, $to);
2810     $from = collapse(@from);
2811     $to = collapse(@to);
2812     $from .= "-" if $delhyphen;
2813     return ($from, $to);
2814 }
2815
2816 sub tr_chr {
2817     my $x = shift;
2818     if ($x == ord "-") {
2819         return "\\-";
2820     } else {
2821         return chr $x;
2822     }
2823 }
2824
2825 # XXX This doesn't yet handle all cases correctly either
2826
2827 sub tr_decode_utf8 {
2828     my($swash_hv, $flags) = @_;
2829     my %swash = $swash_hv->ARRAY;
2830     my $final = undef;
2831     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2832     my $none = $swash{"NONE"}->IV;
2833     my $extra = $none + 1;
2834     my(@from, @delfrom, @to);
2835     my $line;
2836     foreach $line (split /\n/, $swash{'LIST'}->PV) {
2837         my($min, $max, $result) = split(/\t/, $line);
2838         $min = hex $min;
2839         if (length $max) {
2840             $max = hex $max;
2841         } else {
2842             $max = $min;
2843         }
2844         $result = hex $result;
2845         if ($result == $extra) {
2846             push @delfrom, [$min, $max];
2847         } else {
2848             push @from, [$min, $max];
2849             push @to, [$result, $result + $max - $min];
2850         }
2851     }
2852     for my $i (0 .. $#from) {
2853         if ($from[$i][0] == ord '-') {
2854             unshift @from, splice(@from, $i, 1);
2855             unshift @to, splice(@to, $i, 1);
2856             last;
2857         } elsif ($from[$i][1] == ord '-') {
2858             $from[$i][1]--;
2859             $to[$i][1]--;
2860             unshift @from, ord '-';
2861             unshift @to, ord '-';
2862             last;
2863         }
2864     }
2865     for my $i (0 .. $#delfrom) {
2866         if ($delfrom[$i][0] == ord '-') {
2867             push @delfrom, splice(@delfrom, $i, 1);
2868             last;
2869         } elsif ($delfrom[$i][1] == ord '-') {
2870             $delfrom[$i][1]--;
2871             push @delfrom, ord '-';
2872             last;
2873         }
2874     }
2875     if (defined $final and $to[$#to][1] != $final) {
2876         push @to, [$final, $final];
2877     }
2878     push @from, @delfrom;
2879     if ($flags & OPpTRANS_COMPLEMENT) {
2880         my @newfrom;
2881         my $next = 0;
2882         for my $i (0 .. $#from) {
2883             push @newfrom, [$next, $from[$i][0] - 1];
2884             $next = $from[$i][1] + 1;
2885         }
2886         @from = ();
2887         for my $range (@newfrom) {
2888             if ($range->[0] <= $range->[1]) {
2889                 push @from, $range;
2890             }
2891         }
2892     }
2893     my($from, $to, $diff);
2894     for my $chunk (@from) {
2895         $diff = $chunk->[1] - $chunk->[0];
2896         if ($diff > 1) {
2897             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2898         } elsif ($diff == 1) {
2899             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2900         } else {
2901             $from .= tr_chr($chunk->[0]);
2902         }
2903     }
2904     for my $chunk (@to) {
2905         $diff = $chunk->[1] - $chunk->[0];
2906         if ($diff > 1) {
2907             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2908         } elsif ($diff == 1) {
2909             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2910         } else {
2911             $to .= tr_chr($chunk->[0]);
2912         }
2913     }
2914     #$final = sprintf("%04x", $final) if defined $final;
2915     #$none = sprintf("%04x", $none) if defined $none;
2916     #$extra = sprintf("%04x", $extra) if defined $extra;
2917     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2918     #print STDERR $swash{'LIST'}->PV;
2919     return (escape_str($from), escape_str($to));
2920 }
2921
2922 sub pp_trans {
2923     my $self = shift;
2924     my($op, $cx) = @_;
2925     my($from, $to);
2926     if (class($op) eq "PVOP") {
2927         ($from, $to) = tr_decode_byte($op->pv, $op->private);
2928     } else { # class($op) eq "SVOP"
2929         ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2930     }
2931     my $flags = "";
2932     $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2933     $flags .= "d" if $op->private & OPpTRANS_DELETE;
2934     $to = "" if $from eq $to and $flags eq "";
2935     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2936     return "tr" . double_delim($from, $to) . $flags;
2937 }
2938
2939 # Like dq(), but different
2940 sub re_dq {
2941     my $self = shift;
2942     my $op = shift;
2943     my $type = $op->name;
2944     if ($type eq "const") {
2945         return re_uninterp(escape_str(re_unback($self->const_sv($op)->PV)));
2946     } elsif ($type eq "concat") {
2947         my $first = $self->re_dq($op->first);
2948         my $last  = $self->re_dq($op->last);
2949         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2950         if ($last =~ /^[{\[\w]/) {
2951             $first =~ s/([%\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2952         }
2953         return $first . $last;
2954     } elsif ($type eq "uc") {
2955         return '\U' . $self->re_dq($op->first->sibling) . '\E';
2956     } elsif ($type eq "lc") {
2957         return '\L' . $self->re_dq($op->first->sibling) . '\E';
2958     } elsif ($type eq "ucfirst") {
2959         return '\u' . $self->re_dq($op->first->sibling);
2960     } elsif ($type eq "lcfirst") {
2961         return '\l' . $self->re_dq($op->first->sibling);
2962     } elsif ($type eq "quotemeta") {
2963         return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2964     } elsif ($type eq "join") {
2965         return $self->deparse($op->last, 26); # was join($", @ary)
2966     } else {
2967         return $self->deparse($op, 26);
2968     }
2969 }
2970
2971 sub pp_regcomp {
2972     my $self = shift;
2973     my($op, $cx) = @_;
2974     my $kid = $op->first;
2975     $kid = $kid->first if $kid->name eq "regcmaybe";
2976     $kid = $kid->first if $kid->name eq "regcreset";
2977     return $self->re_dq($kid);
2978 }
2979
2980 # osmic acid -- see osmium tetroxide
2981
2982 my %matchwords;
2983 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2984     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2985     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2986
2987 sub matchop {
2988     my $self = shift;
2989     my($op, $cx, $name, $delim) = @_;
2990     my $kid = $op->first;
2991     my ($binop, $var, $re) = ("", "", "");
2992     if ($op->flags & OPf_STACKED) {
2993         $binop = 1;
2994         $var = $self->deparse($kid, 20);
2995         $kid = $kid->sibling;
2996     }
2997     if (null $kid) {
2998         $re = re_uninterp(escape_str(re_unback($op->precomp)));
2999     } else {
3000         $re = $self->deparse($kid, 1);
3001     }
3002     my $flags = "";
3003     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3004     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3005     $flags .= "i" if $op->pmflags & PMf_FOLD;
3006     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3007     $flags .= "o" if $op->pmflags & PMf_KEEP;
3008     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3009     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3010     $flags = $matchwords{$flags} if $matchwords{$flags};
3011     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3012         $re =~ s/\?/\\?/g;
3013         $re = "?$re?";
3014     } else {
3015         $re = single_delim($name, $delim, $re);
3016     }
3017     $re = $re . $flags;
3018     if ($binop) {
3019         return $self->maybe_parens("$var =~ $re", $cx, 20);
3020     } else {
3021         return $re;
3022     }
3023 }
3024
3025 sub pp_match { matchop(@_, "m", "/") }
3026 sub pp_pushre { matchop(@_, "m", "/") }
3027 sub pp_qr { matchop(@_, "qr", "") }
3028
3029 sub pp_split {
3030     my $self = shift;
3031     my($op, $cx) = @_;
3032     my($kid, @exprs, $ary, $expr);
3033     $kid = $op->first;
3034     if ($ {$kid->pmreplroot}) {
3035         $ary = '@' . $self->gv_name($kid->pmreplroot);
3036     }
3037     for (; !null($kid); $kid = $kid->sibling) {
3038         push @exprs, $self->deparse($kid, 6);
3039     }
3040
3041     # handle special case of split(), and split(" ") that compiles to /\s+/
3042     $kid = $op->first;
3043     if ($kid->flags & OPf_SPECIAL
3044         && $exprs[0] eq '/\\s+/'
3045         && $kid->pmflags & PMf_SKIPWHITE ) {
3046             $exprs[0] = '" "';
3047     }
3048
3049     $expr = "split(" . join(", ", @exprs) . ")";
3050     if ($ary) {
3051         return $self->maybe_parens("$ary = $expr", $cx, 7);
3052     } else {
3053         return $expr;
3054     }
3055 }
3056
3057 # oxime -- any of various compounds obtained chiefly by the action of
3058 # hydroxylamine on aldehydes and ketones and characterized by the
3059 # bivalent grouping C=NOH [Webster's Tenth]
3060
3061 my %substwords;
3062 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3063     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3064     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3065     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3066
3067 sub pp_subst {
3068     my $self = shift;
3069     my($op, $cx) = @_;
3070     my $kid = $op->first;
3071     my($binop, $var, $re, $repl) = ("", "", "", "");
3072     if ($op->flags & OPf_STACKED) {
3073         $binop = 1;
3074         $var = $self->deparse($kid, 20);
3075         $kid = $kid->sibling;
3076     }
3077     my $flags = "";
3078     if (null($op->pmreplroot)) {
3079         $repl = $self->dq($kid);
3080         $kid = $kid->sibling;
3081     } else {
3082         $repl = $op->pmreplroot->first; # skip substcont
3083         while ($repl->name eq "entereval") {
3084             $repl = $repl->first;
3085             $flags .= "e";
3086         }
3087         if ($op->pmflags & PMf_EVAL) {
3088             $repl = $self->deparse($repl, 0);
3089         } else {
3090             $repl = $self->dq($repl);
3091         }
3092     }
3093     if (null $kid) {
3094         $re = re_uninterp(escape_str(re_unback($op->precomp)));
3095     } else {
3096         $re = $self->deparse($kid, 1);
3097     }
3098     $flags .= "e" if $op->pmflags & PMf_EVAL;
3099     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3100     $flags .= "i" if $op->pmflags & PMf_FOLD;
3101     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3102     $flags .= "o" if $op->pmflags & PMf_KEEP;
3103     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3104     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3105     $flags = $substwords{$flags} if $substwords{$flags};
3106     if ($binop) {
3107         return $self->maybe_parens("$var =~ s"
3108                                    . double_delim($re, $repl) . $flags,
3109                                    $cx, 20);
3110     } else {
3111         return "s". double_delim($re, $repl) . $flags;
3112     }
3113 }
3114
3115 1;
3116 __END__
3117
3118 =head1 NAME
3119
3120 B::Deparse - Perl compiler backend to produce perl code
3121
3122 =head1 SYNOPSIS
3123
3124 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3125         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3126
3127 =head1 DESCRIPTION
3128
3129 B::Deparse is a backend module for the Perl compiler that generates
3130 perl source code, based on the internal compiled structure that perl
3131 itself creates after parsing a program. The output of B::Deparse won't
3132 be exactly the same as the original source, since perl doesn't keep
3133 track of comments or whitespace, and there isn't a one-to-one
3134 correspondence between perl's syntactical constructions and their
3135 compiled form, but it will often be close. When you use the B<-p>
3136 option, the output also includes parentheses even when they are not
3137 required by precedence, which can make it easy to see if perl is
3138 parsing your expressions the way you intended.
3139
3140 Please note that this module is mainly new and untested code and is
3141 still under development, so it may change in the future.
3142
3143 =head1 OPTIONS
3144
3145 As with all compiler backend options, these must follow directly after
3146 the '-MO=Deparse', separated by a comma but not any white space.
3147
3148 =over 4
3149
3150 =item B<-l>
3151
3152 Add '#line' declarations to the output based on the line and file
3153 locations of the original code.
3154
3155 =item B<-p>
3156
3157 Print extra parentheses. Without this option, B::Deparse includes
3158 parentheses in its output only when they are needed, based on the
3159 structure of your program. With B<-p>, it uses parentheses (almost)
3160 whenever they would be legal. This can be useful if you are used to
3161 LISP, or if you want to see how perl parses your input. If you say
3162
3163     if ($var & 0x7f == 65) {print "Gimme an A!"}
3164     print ($which ? $a : $b), "\n";
3165     $name = $ENV{USER} or "Bob";
3166
3167 C<B::Deparse,-p> will print
3168
3169     if (($var & 0)) {
3170         print('Gimme an A!')
3171     };
3172     (print(($which ? $a : $b)), '???');
3173     (($name = $ENV{'USER'}) or '???')
3174
3175 which probably isn't what you intended (the C<'???'> is a sign that
3176 perl optimized away a constant value).
3177
3178 =item B<-q>
3179
3180 Expand double-quoted strings into the corresponding combinations of
3181 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3182 instance, print
3183
3184     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3185
3186 as
3187
3188     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3189           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3190
3191 Note that the expanded form represents the way perl handles such
3192 constructions internally -- this option actually turns off the reverse
3193 translation that B::Deparse usually does. On the other hand, note that
3194 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3195 of $y into a string before doing the assignment.
3196
3197 =item B<-u>I<PACKAGE>
3198
3199 Normally, B::Deparse deparses the main code of a program, all the subs
3200 called by the main program (and all the subs called by them,
3201 recursively), and any other subs in the main:: package. To include
3202 subs in other packages that aren't called directly, such as AUTOLOAD,
3203 DESTROY, other subs called automatically by perl, and methods (which
3204 aren't resolved to subs until runtime), use the B<-u> option. The
3205 argument to B<-u> is the name of a package, and should follow directly
3206 after the 'u'. Multiple B<-u> options may be given, separated by
3207 commas.  Note that unlike some other backends, B::Deparse doesn't
3208 (yet) try to guess automatically when B<-u> is needed -- you must
3209 invoke it yourself.
3210
3211 =item B<-s>I<LETTERS>
3212
3213 Tweak the style of B::Deparse's output. The letters should follow
3214 directly after the 's', with no space or punctuation. The following
3215 options are available:
3216
3217 =over 4
3218
3219 =item B<C>
3220
3221 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3222
3223     if (...) {
3224          ...
3225     } else {
3226          ...
3227     }
3228
3229 instead of
3230
3231     if (...) {
3232          ...
3233     }
3234     else {
3235          ...
3236     }
3237
3238 The default is not to cuddle.
3239
3240 =item B<i>I<NUMBER>
3241
3242 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3243
3244 =item B<T>
3245
3246 Use tabs for each 8 columns of indent. The default is to use only spaces.
3247 For instance, if the style options are B<-si4T>, a line that's indented
3248 3 times will be preceded by one tab and four spaces; if the options were
3249 B<-si8T>, the same line would be preceded by three tabs.
3250
3251 =item B<v>I<STRING>B<.>
3252
3253 Print I<STRING> for the value of a constant that can't be determined
3254 because it was optimized away (mnemonic: this happens when a constant
3255 is used in B<v>oid context). The end of the string is marked by a period.
3256 The string should be a valid perl expression, generally a constant.
3257 Note that unless it's a number, it probably needs to be quoted, and on
3258 a command line quotes need to be protected from the shell. Some
3259 conventional values include 0, 1, 42, '', 'foo', and
3260 'Useless use of constant omitted' (which may need to be
3261 B<-sv"'Useless use of constant omitted'.">
3262 or something similar depending on your shell). The default is '???'.
3263 If you're using B::Deparse on a module or other file that's require'd,
3264 you shouldn't use a value that evaluates to false, since the customary
3265 true constant at the end of a module will be in void context when the
3266 file is compiled as a main program.
3267
3268 =back
3269
3270 =item B<-x>I<LEVEL>
3271
3272 Expand conventional syntax constructions into equivalent ones that expose
3273 their internal operation. I<LEVEL> should be a digit, with higher values
3274 meaning more expansion. As with B<-q>, this actually involves turning off
3275 special cases in B::Deparse's normal operations.
3276
3277 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3278 while loops with continue blocks; for instance
3279
3280     for ($i = 0; $i < 10; ++$i) {
3281         print $i;
3282     }
3283
3284 turns into
3285
3286     $i = 0;
3287     while ($i < 10) {
3288         print $i;
3289     } continue {
3290         ++$i
3291     }
3292
3293 Note that in a few cases this translation can't be perfectly carried back
3294 into the source code -- if the loop's initializer declares a my variable,
3295 for instance, it won't have the correct scope outside of the loop.
3296
3297 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3298 expressions using C<&&>, C<?:> and C<do {}>; for instance
3299
3300     print 'hi' if $nice;
3301     if ($nice) {
3302         print 'hi';
3303     }
3304     if ($nice) {
3305         print 'hi';
3306     } else {
3307         print 'bye';
3308     }
3309
3310 turns into
3311
3312     $nice and print 'hi';
3313     $nice and do { print 'hi' };
3314     $nice ? do { print 'hi' } : do { print 'bye' };
3315
3316 Long sequences of elsifs will turn into nested ternary operators, which
3317 B::Deparse doesn't know how to indent nicely.
3318
3319 =back
3320
3321 =head1 USING B::Deparse AS A MODULE
3322
3323 =head2 Synopsis
3324
3325     use B::Deparse;
3326     $deparse = B::Deparse->new("-p", "-sC");
3327     $body = $deparse->coderef2text(\&func);
3328     eval "sub func $body"; # the inverse operation
3329
3330 =head2 Description
3331
3332 B::Deparse can also be used on a sub-by-sub basis from other perl
3333 programs.
3334
3335 =head2 new
3336
3337     $deparse = B::Deparse->new(OPTIONS)
3338
3339 Create an object to store the state of a deparsing operation and any
3340 options. The options are the same as those that can be given on the
3341 command line (see L</OPTIONS>); options that are separated by commas
3342 after B<-MO=Deparse> should be given as separate strings. Some
3343 options, like B<-u>, don't make sense for a single subroutine, so
3344 don't pass them.
3345
3346 =head2 ambient_pragmas
3347
3348     $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3349
3350 The compilation of a subroutine can be affected by a few compiler
3351 directives, B<pragmas>. These are:
3352
3353 =over 4
3354
3355 =item *
3356
3357 use strict;
3358
3359 =item *
3360
3361 use warnings;
3362
3363 =item *
3364
3365 Assigning to the special variable $[
3366
3367 =item *
3368
3369 use integer;
3370
3371 =item *
3372
3373 use bytes;
3374
3375 =item *
3376
3377 use utf8;
3378
3379 =item *
3380
3381 use re;
3382
3383 =back
3384
3385 Ordinarily, if you use B::Deparse on a subroutine which has
3386 been compiled in the presence of one or more of these pragmas,
3387 the output will include statements to turn on the appropriate
3388 directives. So if you then compile the code returned by coderef2text,
3389 it will behave the same way as the subroutine which you deparsed.
3390
3391 However, you may know that you intend to use the results in a
3392 particular context, where some pragmas are already in scope. In
3393 this case, you use the B<ambient_pragmas> method to describe the
3394 assumptions you wish to make.
3395
3396 The parameters it accepts are:
3397
3398 =over 4
3399
3400 =item strict
3401
3402 Takes a string, possibly containing several values separated
3403 by whitespace. The special values "all" and "none" mean what you'd
3404 expect.
3405
3406     $deparse->ambient_pragmas(strict => 'subs refs');
3407
3408 =item $[
3409
3410 Takes a number, the value of the array base $[.
3411
3412 =item bytes
3413
3414 =item utf8
3415
3416 =item integer
3417
3418 If the value is true, then the appropriate pragma is assumed to
3419 be in the ambient scope, otherwise not.
3420
3421 =item re
3422
3423 Takes a string, possibly containing a whitespace-separated list of
3424 values. The values "all" and "none" are special. It's also permissible
3425 to pass an array reference here.
3426
3427     $deparser->ambient_pragmas(re => 'eval');
3428
3429
3430 =item warnings
3431
3432 Takes a string, possibly containing a whitespace-separated list of
3433 values. The values "all" and "none" are special, again. It's also
3434 permissible to pass an array reference here.
3435
3436     $deparser->ambient_pragmas(warnings => [qw[void io]]);
3437
3438 If one of the values is the string "FATAL", then all the warnings
3439 in that list will be considered fatal, just as with the B<warnings>
3440 pragma itself. Should you need to specify that some warnings are
3441 fatal, and others are merely enabled, you can pass the B<warnings>
3442 parameter twice:
3443
3444     $deparser->ambient_pragmas(
3445         warnings => 'all',
3446         warnings => [FATAL => qw/void io/],
3447     );
3448
3449 See L<perllexwarn> for more information about lexical warnings.
3450
3451 =item hint_bits
3452
3453 =item warning_bits
3454
3455 These two parameters are used to specify the ambient pragmas in
3456 the format used by the special variables $^H and ${^WARNING_BITS}.
3457
3458 They exist principally so that you can write code like:
3459
3460     { my ($hint_bits, $warning_bits);
3461     BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3462     $deparser->ambient_pragmas (
3463         hint_bits    => $hint_bits,
3464         warning_bits => $warning_bits,
3465         '$['         => 0 + $[
3466     ); }
3467
3468 which specifies that the ambient pragmas are exactly those which
3469 are in scope at the point of calling.
3470
3471 =back
3472
3473 =head2 coderef2text
3474
3475     $body = $deparse->coderef2text(\&func)
3476     $body = $deparse->coderef2text(sub ($$) { ... })
3477
3478 Return source code for the body of a subroutine (a block, optionally
3479 preceded by a prototype in parens), given a reference to the
3480 sub. Because a subroutine can have no names, or more than one name,
3481 this method doesn't return a complete subroutine definition -- if you
3482 want to eval the result, you should prepend "sub subname ", or "sub "
3483 for an anonymous function constructor. Unless the sub was defined in
3484 the main:: package, the code will include a package declaration.
3485
3486 =head1 BUGS
3487
3488 See the 'to do' list at the beginning of the module file.
3489
3490 =head1 AUTHOR
3491
3492 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3493 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3494 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3495 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
3496
3497 =cut