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_ARYBASE) {
2634         return '$[';
2635     }
2636 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2637 #       return $self->const_sv($op)->PV;
2638 #    }
2639     my $sv = $self->const_sv($op);
2640 #    return const($sv);
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 '$[' if $op->private & OPpCONST_ARYBASE;
2651         return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
2652     } elsif ($type eq "concat") {
2653         my $first = $self->dq($op->first);
2654         my $last  = $self->dq($op->last);
2655         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2656         if ($last =~ /^[A-Z\\\^\[\]_?]/) {
2657             $first =~ s/([\$@])\^$/${1}{^}/;  # "${^}W" etc
2658         }
2659         elsif ($last =~ /^[{\[\w]/) {
2660             $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2661         }
2662         return $first . $last;
2663     } elsif ($type eq "uc") {
2664         return '\U' . $self->dq($op->first->sibling) . '\E';
2665     } elsif ($type eq "lc") {
2666         return '\L' . $self->dq($op->first->sibling) . '\E';
2667     } elsif ($type eq "ucfirst") {
2668         return '\u' . $self->dq($op->first->sibling);
2669     } elsif ($type eq "lcfirst") {
2670         return '\l' . $self->dq($op->first->sibling);
2671     } elsif ($type eq "quotemeta") {
2672         return '\Q' . $self->dq($op->first->sibling) . '\E';
2673     } elsif ($type eq "join") {
2674         return $self->deparse($op->last, 26); # was join($", @ary)
2675     } else {
2676         return $self->deparse($op, 26);
2677     }
2678 }
2679
2680 sub pp_backtick {
2681     my $self = shift;
2682     my($op, $cx) = @_;
2683     # skip pushmark
2684     return single_delim("qx", '`', $self->dq($op->first->sibling));
2685 }
2686
2687 sub dquote {
2688     my $self = shift;
2689     my($op, $cx) = @_;
2690     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2691     return $self->deparse($kid, $cx) if $self->{'unquote'};
2692     $self->maybe_targmy($kid, $cx,
2693                         sub {single_delim("qq", '"', $self->dq($_[1]))});
2694 }
2695
2696 # OP_STRINGIFY is a listop, but it only ever has one arg
2697 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2698
2699 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2700 # note that tr(from)/to/ is OK, but not tr/from/(to)
2701 sub double_delim {
2702     my($from, $to) = @_;
2703     my($succeed, $delim);
2704     if ($from !~ m[/] and $to !~ m[/]) {
2705         return "/$from/$to/";
2706     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2707         if (($succeed, $to) = balanced_delim($to) and $succeed) {
2708             return "$from$to";
2709         } else {
2710             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2711                 return "$from$delim$to$delim" if index($to, $delim) == -1;
2712             }
2713             $to =~ s[/][\\/]g;
2714             return "$from/$to/";
2715         }
2716     } else {
2717         for $delim ('/', '"', '#') { # note no '
2718             return "$delim$from$delim$to$delim"
2719                 if index($to . $from, $delim) == -1;
2720         }
2721         $from =~ s[/][\\/]g;
2722         $to =~ s[/][\\/]g;
2723         return "/$from/$to/";
2724     }
2725 }
2726
2727 sub pchr { # ASCII
2728     my($n) = @_;
2729     if ($n == ord '\\') {
2730         return '\\\\';
2731     } elsif ($n >= ord(' ') and $n <= ord('~')) {
2732         return chr($n);
2733     } elsif ($n == ord "\a") {
2734         return '\\a';
2735     } elsif ($n == ord "\b") {
2736         return '\\b';
2737     } elsif ($n == ord "\t") {
2738         return '\\t';
2739     } elsif ($n == ord "\n") {
2740         return '\\n';
2741     } elsif ($n == ord "\e") {
2742         return '\\e';
2743     } elsif ($n == ord "\f") {
2744         return '\\f';
2745     } elsif ($n == ord "\r") {
2746         return '\\r';
2747     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2748         return '\\c' . chr(ord("@") + $n);
2749     } else {
2750 #       return '\x' . sprintf("%02x", $n);
2751         return '\\' . sprintf("%03o", $n);
2752     }
2753 }
2754
2755 sub collapse {
2756     my(@chars) = @_;
2757     my($str, $c, $tr) = ("");
2758     for ($c = 0; $c < @chars; $c++) {
2759         $tr = $chars[$c];
2760         $str .= pchr($tr);
2761         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2762             $chars[$c + 2] == $tr + 2)
2763         {
2764             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2765               {}
2766             $str .= "-";
2767             $str .= pchr($chars[$c]);
2768         }
2769     }
2770     return $str;
2771 }
2772
2773 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2774 # and backslashes.
2775
2776 sub tr_decode_byte {
2777     my($table, $flags) = @_;
2778     my(@table) = unpack("s256", $table);
2779     my($c, $tr, @from, @to, @delfrom, $delhyphen);
2780     if ($table[ord "-"] != -1 and
2781         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2782     {
2783         $tr = $table[ord "-"];
2784         $table[ord "-"] = -1;
2785         if ($tr >= 0) {
2786             @from = ord("-");
2787             @to = $tr;
2788         } else { # -2 ==> delete
2789             $delhyphen = 1;
2790         }
2791     }
2792     for ($c = 0; $c < 256; $c++) {
2793         $tr = $table[$c];
2794         if ($tr >= 0) {
2795             push @from, $c; push @to, $tr;
2796         } elsif ($tr == -2) {
2797             push @delfrom, $c;
2798         }
2799     }
2800     @from = (@from, @delfrom);
2801     if ($flags & OPpTRANS_COMPLEMENT) {
2802         my @newfrom = ();
2803         my %from;
2804         @from{@from} = (1) x @from;
2805         for ($c = 0; $c < 256; $c++) {
2806             push @newfrom, $c unless $from{$c};
2807         }
2808         @from = @newfrom;
2809     }
2810     unless ($flags & OPpTRANS_DELETE || !@to) {
2811         pop @to while $#to and $to[$#to] == $to[$#to -1];
2812     }
2813     my($from, $to);
2814     $from = collapse(@from);
2815     $to = collapse(@to);
2816     $from .= "-" if $delhyphen;
2817     return ($from, $to);
2818 }
2819
2820 sub tr_chr {
2821     my $x = shift;
2822     if ($x == ord "-") {
2823         return "\\-";
2824     } else {
2825         return chr $x;
2826     }
2827 }
2828
2829 # XXX This doesn't yet handle all cases correctly either
2830
2831 sub tr_decode_utf8 {
2832     my($swash_hv, $flags) = @_;
2833     my %swash = $swash_hv->ARRAY;
2834     my $final = undef;
2835     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2836     my $none = $swash{"NONE"}->IV;
2837     my $extra = $none + 1;
2838     my(@from, @delfrom, @to);
2839     my $line;
2840     foreach $line (split /\n/, $swash{'LIST'}->PV) {
2841         my($min, $max, $result) = split(/\t/, $line);
2842         $min = hex $min;
2843         if (length $max) {
2844             $max = hex $max;
2845         } else {
2846             $max = $min;
2847         }
2848         $result = hex $result;
2849         if ($result == $extra) {
2850             push @delfrom, [$min, $max];
2851         } else {
2852             push @from, [$min, $max];
2853             push @to, [$result, $result + $max - $min];
2854         }
2855     }
2856     for my $i (0 .. $#from) {
2857         if ($from[$i][0] == ord '-') {
2858             unshift @from, splice(@from, $i, 1);
2859             unshift @to, splice(@to, $i, 1);
2860             last;
2861         } elsif ($from[$i][1] == ord '-') {
2862             $from[$i][1]--;
2863             $to[$i][1]--;
2864             unshift @from, ord '-';
2865             unshift @to, ord '-';
2866             last;
2867         }
2868     }
2869     for my $i (0 .. $#delfrom) {
2870         if ($delfrom[$i][0] == ord '-') {
2871             push @delfrom, splice(@delfrom, $i, 1);
2872             last;
2873         } elsif ($delfrom[$i][1] == ord '-') {
2874             $delfrom[$i][1]--;
2875             push @delfrom, ord '-';
2876             last;
2877         }
2878     }
2879     if (defined $final and $to[$#to][1] != $final) {
2880         push @to, [$final, $final];
2881     }
2882     push @from, @delfrom;
2883     if ($flags & OPpTRANS_COMPLEMENT) {
2884         my @newfrom;
2885         my $next = 0;
2886         for my $i (0 .. $#from) {
2887             push @newfrom, [$next, $from[$i][0] - 1];
2888             $next = $from[$i][1] + 1;
2889         }
2890         @from = ();
2891         for my $range (@newfrom) {
2892             if ($range->[0] <= $range->[1]) {
2893                 push @from, $range;
2894             }
2895         }
2896     }
2897     my($from, $to, $diff);
2898     for my $chunk (@from) {
2899         $diff = $chunk->[1] - $chunk->[0];
2900         if ($diff > 1) {
2901             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2902         } elsif ($diff == 1) {
2903             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2904         } else {
2905             $from .= tr_chr($chunk->[0]);
2906         }
2907     }
2908     for my $chunk (@to) {
2909         $diff = $chunk->[1] - $chunk->[0];
2910         if ($diff > 1) {
2911             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2912         } elsif ($diff == 1) {
2913             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2914         } else {
2915             $to .= tr_chr($chunk->[0]);
2916         }
2917     }
2918     #$final = sprintf("%04x", $final) if defined $final;
2919     #$none = sprintf("%04x", $none) if defined $none;
2920     #$extra = sprintf("%04x", $extra) if defined $extra;
2921     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2922     #print STDERR $swash{'LIST'}->PV;
2923     return (escape_str($from), escape_str($to));
2924 }
2925
2926 sub pp_trans {
2927     my $self = shift;
2928     my($op, $cx) = @_;
2929     my($from, $to);
2930     if (class($op) eq "PVOP") {
2931         ($from, $to) = tr_decode_byte($op->pv, $op->private);
2932     } else { # class($op) eq "SVOP"
2933         ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2934     }
2935     my $flags = "";
2936     $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2937     $flags .= "d" if $op->private & OPpTRANS_DELETE;
2938     $to = "" if $from eq $to and $flags eq "";
2939     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2940     return "tr" . double_delim($from, $to) . $flags;
2941 }
2942
2943 # Like dq(), but different
2944 sub re_dq {
2945     my $self = shift;
2946     my $op = shift;
2947     my $type = $op->name;
2948     if ($type eq "const") {
2949         return '$[' if $op->private & OPpCONST_ARYBASE;
2950         return re_uninterp(escape_str(re_unback($self->const_sv($op)->as_string)));
2951     } elsif ($type eq "concat") {
2952         my $first = $self->re_dq($op->first);
2953         my $last  = $self->re_dq($op->last);
2954         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2955         if ($last =~ /^[A-Z\\\^\[\]_?]/) {
2956             $first =~ s/([\$@])\^$/${1}{^}/;
2957         }
2958         elsif ($last =~ /^[{\[\w]/) {
2959             $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2960         }
2961         return $first . $last;
2962     } elsif ($type eq "uc") {
2963         return '\U' . $self->re_dq($op->first->sibling) . '\E';
2964     } elsif ($type eq "lc") {
2965         return '\L' . $self->re_dq($op->first->sibling) . '\E';
2966     } elsif ($type eq "ucfirst") {
2967         return '\u' . $self->re_dq($op->first->sibling);
2968     } elsif ($type eq "lcfirst") {
2969         return '\l' . $self->re_dq($op->first->sibling);
2970     } elsif ($type eq "quotemeta") {
2971         return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2972     } elsif ($type eq "join") {
2973         return $self->deparse($op->last, 26); # was join($", @ary)
2974     } else {
2975         return $self->deparse($op, 26);
2976     }
2977 }
2978
2979 sub pp_regcomp {
2980     my $self = shift;
2981     my($op, $cx) = @_;
2982     my $kid = $op->first;
2983     $kid = $kid->first if $kid->name eq "regcmaybe";
2984     $kid = $kid->first if $kid->name eq "regcreset";
2985     return $self->re_dq($kid);
2986 }
2987
2988 # osmic acid -- see osmium tetroxide
2989
2990 my %matchwords;
2991 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2992     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2993     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2994
2995 sub matchop {
2996     my $self = shift;
2997     my($op, $cx, $name, $delim) = @_;
2998     my $kid = $op->first;
2999     my ($binop, $var, $re) = ("", "", "");
3000     if ($op->flags & OPf_STACKED) {
3001         $binop = 1;
3002         $var = $self->deparse($kid, 20);
3003         $kid = $kid->sibling;
3004     }
3005     if (null $kid) {
3006         $re = re_uninterp(escape_str(re_unback($op->precomp)));
3007     } else {
3008         $re = $self->deparse($kid, 1);
3009     }
3010     my $flags = "";
3011     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3012     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3013     $flags .= "i" if $op->pmflags & PMf_FOLD;
3014     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3015     $flags .= "o" if $op->pmflags & PMf_KEEP;
3016     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3017     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3018     $flags = $matchwords{$flags} if $matchwords{$flags};
3019     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3020         $re =~ s/\?/\\?/g;
3021         $re = "?$re?";
3022     } else {
3023         $re = single_delim($name, $delim, $re);
3024     }
3025     $re = $re . $flags;
3026     if ($binop) {
3027         return $self->maybe_parens("$var =~ $re", $cx, 20);
3028     } else {
3029         return $re;
3030     }
3031 }
3032
3033 sub pp_match { matchop(@_, "m", "/") }
3034 sub pp_pushre { matchop(@_, "m", "/") }
3035 sub pp_qr { matchop(@_, "qr", "") }
3036
3037 sub pp_split {
3038     my $self = shift;
3039     my($op, $cx) = @_;
3040     my($kid, @exprs, $ary, $expr);
3041     $kid = $op->first;
3042     if ($ {$kid->pmreplroot}) {
3043         $ary = '@' . $self->gv_name($kid->pmreplroot);
3044     }
3045     for (; !null($kid); $kid = $kid->sibling) {
3046         push @exprs, $self->deparse($kid, 6);
3047     }
3048
3049     # handle special case of split(), and split(" ") that compiles to /\s+/
3050     $kid = $op->first;
3051     if ($kid->flags & OPf_SPECIAL
3052         && $exprs[0] eq '/\\s+/'
3053         && $kid->pmflags & PMf_SKIPWHITE ) {
3054             $exprs[0] = '" "';
3055     }
3056
3057     $expr = "split(" . join(", ", @exprs) . ")";
3058     if ($ary) {
3059         return $self->maybe_parens("$ary = $expr", $cx, 7);
3060     } else {
3061         return $expr;
3062     }
3063 }
3064
3065 # oxime -- any of various compounds obtained chiefly by the action of
3066 # hydroxylamine on aldehydes and ketones and characterized by the
3067 # bivalent grouping C=NOH [Webster's Tenth]
3068
3069 my %substwords;
3070 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3071     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3072     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3073     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3074
3075 sub pp_subst {
3076     my $self = shift;
3077     my($op, $cx) = @_;
3078     my $kid = $op->first;
3079     my($binop, $var, $re, $repl) = ("", "", "", "");
3080     if ($op->flags & OPf_STACKED) {
3081         $binop = 1;
3082         $var = $self->deparse($kid, 20);
3083         $kid = $kid->sibling;
3084     }
3085     my $flags = "";
3086     if (null($op->pmreplroot)) {
3087         $repl = $self->dq($kid);
3088         $kid = $kid->sibling;
3089     } else {
3090         $repl = $op->pmreplroot->first; # skip substcont
3091         while ($repl->name eq "entereval") {
3092             $repl = $repl->first;
3093             $flags .= "e";
3094         }
3095         if ($op->pmflags & PMf_EVAL) {
3096             $repl = $self->deparse($repl, 0);
3097         } else {
3098             $repl = $self->dq($repl);
3099         }
3100     }
3101     if (null $kid) {
3102         $re = re_uninterp(escape_str(re_unback($op->precomp)));
3103     } else {
3104         $re = $self->deparse($kid, 1);
3105     }
3106     $flags .= "e" if $op->pmflags & PMf_EVAL;
3107     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3108     $flags .= "i" if $op->pmflags & PMf_FOLD;
3109     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3110     $flags .= "o" if $op->pmflags & PMf_KEEP;
3111     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3112     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3113     $flags = $substwords{$flags} if $substwords{$flags};
3114     if ($binop) {
3115         return $self->maybe_parens("$var =~ s"
3116                                    . double_delim($re, $repl) . $flags,
3117                                    $cx, 20);
3118     } else {
3119         return "s". double_delim($re, $repl) . $flags;
3120     }
3121 }
3122
3123 1;
3124 __END__
3125
3126 =head1 NAME
3127
3128 B::Deparse - Perl compiler backend to produce perl code
3129
3130 =head1 SYNOPSIS
3131
3132 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3133         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3134
3135 =head1 DESCRIPTION
3136
3137 B::Deparse is a backend module for the Perl compiler that generates
3138 perl source code, based on the internal compiled structure that perl
3139 itself creates after parsing a program. The output of B::Deparse won't
3140 be exactly the same as the original source, since perl doesn't keep
3141 track of comments or whitespace, and there isn't a one-to-one
3142 correspondence between perl's syntactical constructions and their
3143 compiled form, but it will often be close. When you use the B<-p>
3144 option, the output also includes parentheses even when they are not
3145 required by precedence, which can make it easy to see if perl is
3146 parsing your expressions the way you intended.
3147
3148 Please note that this module is mainly new and untested code and is
3149 still under development, so it may change in the future.
3150
3151 =head1 OPTIONS
3152
3153 As with all compiler backend options, these must follow directly after
3154 the '-MO=Deparse', separated by a comma but not any white space.
3155
3156 =over 4
3157
3158 =item B<-l>
3159
3160 Add '#line' declarations to the output based on the line and file
3161 locations of the original code.
3162
3163 =item B<-p>
3164
3165 Print extra parentheses. Without this option, B::Deparse includes
3166 parentheses in its output only when they are needed, based on the
3167 structure of your program. With B<-p>, it uses parentheses (almost)
3168 whenever they would be legal. This can be useful if you are used to
3169 LISP, or if you want to see how perl parses your input. If you say
3170
3171     if ($var & 0x7f == 65) {print "Gimme an A!"}
3172     print ($which ? $a : $b), "\n";
3173     $name = $ENV{USER} or "Bob";
3174
3175 C<B::Deparse,-p> will print
3176
3177     if (($var & 0)) {
3178         print('Gimme an A!')
3179     };
3180     (print(($which ? $a : $b)), '???');
3181     (($name = $ENV{'USER'}) or '???')
3182
3183 which probably isn't what you intended (the C<'???'> is a sign that
3184 perl optimized away a constant value).
3185
3186 =item B<-q>
3187
3188 Expand double-quoted strings into the corresponding combinations of
3189 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3190 instance, print
3191
3192     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3193
3194 as
3195
3196     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3197           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3198
3199 Note that the expanded form represents the way perl handles such
3200 constructions internally -- this option actually turns off the reverse
3201 translation that B::Deparse usually does. On the other hand, note that
3202 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3203 of $y into a string before doing the assignment.
3204
3205 =item B<-u>I<PACKAGE>
3206
3207 Normally, B::Deparse deparses the main code of a program, all the subs
3208 called by the main program (and all the subs called by them,
3209 recursively), and any other subs in the main:: package. To include
3210 subs in other packages that aren't called directly, such as AUTOLOAD,
3211 DESTROY, other subs called automatically by perl, and methods (which
3212 aren't resolved to subs until runtime), use the B<-u> option. The
3213 argument to B<-u> is the name of a package, and should follow directly
3214 after the 'u'. Multiple B<-u> options may be given, separated by
3215 commas.  Note that unlike some other backends, B::Deparse doesn't
3216 (yet) try to guess automatically when B<-u> is needed -- you must
3217 invoke it yourself.
3218
3219 =item B<-s>I<LETTERS>
3220
3221 Tweak the style of B::Deparse's output. The letters should follow
3222 directly after the 's', with no space or punctuation. The following
3223 options are available:
3224
3225 =over 4
3226
3227 =item B<C>
3228
3229 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3230
3231     if (...) {
3232          ...
3233     } else {
3234          ...
3235     }
3236
3237 instead of
3238
3239     if (...) {
3240          ...
3241     }
3242     else {
3243          ...
3244     }
3245
3246 The default is not to cuddle.
3247
3248 =item B<i>I<NUMBER>
3249
3250 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3251
3252 =item B<T>
3253
3254 Use tabs for each 8 columns of indent. The default is to use only spaces.
3255 For instance, if the style options are B<-si4T>, a line that's indented
3256 3 times will be preceded by one tab and four spaces; if the options were
3257 B<-si8T>, the same line would be preceded by three tabs.
3258
3259 =item B<v>I<STRING>B<.>
3260
3261 Print I<STRING> for the value of a constant that can't be determined
3262 because it was optimized away (mnemonic: this happens when a constant
3263 is used in B<v>oid context). The end of the string is marked by a period.
3264 The string should be a valid perl expression, generally a constant.
3265 Note that unless it's a number, it probably needs to be quoted, and on
3266 a command line quotes need to be protected from the shell. Some
3267 conventional values include 0, 1, 42, '', 'foo', and
3268 'Useless use of constant omitted' (which may need to be
3269 B<-sv"'Useless use of constant omitted'.">
3270 or something similar depending on your shell). The default is '???'.
3271 If you're using B::Deparse on a module or other file that's require'd,
3272 you shouldn't use a value that evaluates to false, since the customary
3273 true constant at the end of a module will be in void context when the
3274 file is compiled as a main program.
3275
3276 =back
3277
3278 =item B<-x>I<LEVEL>
3279
3280 Expand conventional syntax constructions into equivalent ones that expose
3281 their internal operation. I<LEVEL> should be a digit, with higher values
3282 meaning more expansion. As with B<-q>, this actually involves turning off
3283 special cases in B::Deparse's normal operations.
3284
3285 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3286 while loops with continue blocks; for instance
3287
3288     for ($i = 0; $i < 10; ++$i) {
3289         print $i;
3290     }
3291
3292 turns into
3293
3294     $i = 0;
3295     while ($i < 10) {
3296         print $i;
3297     } continue {
3298         ++$i
3299     }
3300
3301 Note that in a few cases this translation can't be perfectly carried back
3302 into the source code -- if the loop's initializer declares a my variable,
3303 for instance, it won't have the correct scope outside of the loop.
3304
3305 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3306 expressions using C<&&>, C<?:> and C<do {}>; for instance
3307
3308     print 'hi' if $nice;
3309     if ($nice) {
3310         print 'hi';
3311     }
3312     if ($nice) {
3313         print 'hi';
3314     } else {
3315         print 'bye';
3316     }
3317
3318 turns into
3319
3320     $nice and print 'hi';
3321     $nice and do { print 'hi' };
3322     $nice ? do { print 'hi' } : do { print 'bye' };
3323
3324 Long sequences of elsifs will turn into nested ternary operators, which
3325 B::Deparse doesn't know how to indent nicely.
3326
3327 =back
3328
3329 =head1 USING B::Deparse AS A MODULE
3330
3331 =head2 Synopsis
3332
3333     use B::Deparse;
3334     $deparse = B::Deparse->new("-p", "-sC");
3335     $body = $deparse->coderef2text(\&func);
3336     eval "sub func $body"; # the inverse operation
3337
3338 =head2 Description
3339
3340 B::Deparse can also be used on a sub-by-sub basis from other perl
3341 programs.
3342
3343 =head2 new
3344
3345     $deparse = B::Deparse->new(OPTIONS)
3346
3347 Create an object to store the state of a deparsing operation and any
3348 options. The options are the same as those that can be given on the
3349 command line (see L</OPTIONS>); options that are separated by commas
3350 after B<-MO=Deparse> should be given as separate strings. Some
3351 options, like B<-u>, don't make sense for a single subroutine, so
3352 don't pass them.
3353
3354 =head2 ambient_pragmas
3355
3356     $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3357
3358 The compilation of a subroutine can be affected by a few compiler
3359 directives, B<pragmas>. These are:
3360
3361 =over 4
3362
3363 =item *
3364
3365 use strict;
3366
3367 =item *
3368
3369 use warnings;
3370
3371 =item *
3372
3373 Assigning to the special variable $[
3374
3375 =item *
3376
3377 use integer;
3378
3379 =item *
3380
3381 use bytes;
3382
3383 =item *
3384
3385 use utf8;
3386
3387 =item *
3388
3389 use re;
3390
3391 =back
3392
3393 Ordinarily, if you use B::Deparse on a subroutine which has
3394 been compiled in the presence of one or more of these pragmas,
3395 the output will include statements to turn on the appropriate
3396 directives. So if you then compile the code returned by coderef2text,
3397 it will behave the same way as the subroutine which you deparsed.
3398
3399 However, you may know that you intend to use the results in a
3400 particular context, where some pragmas are already in scope. In
3401 this case, you use the B<ambient_pragmas> method to describe the
3402 assumptions you wish to make.
3403
3404 The parameters it accepts are:
3405
3406 =over 4
3407
3408 =item strict
3409
3410 Takes a string, possibly containing several values separated
3411 by whitespace. The special values "all" and "none" mean what you'd
3412 expect.
3413
3414     $deparse->ambient_pragmas(strict => 'subs refs');
3415
3416 =item $[
3417
3418 Takes a number, the value of the array base $[.
3419
3420 =item bytes
3421
3422 =item utf8
3423
3424 =item integer
3425
3426 If the value is true, then the appropriate pragma is assumed to
3427 be in the ambient scope, otherwise not.
3428
3429 =item re
3430
3431 Takes a string, possibly containing a whitespace-separated list of
3432 values. The values "all" and "none" are special. It's also permissible
3433 to pass an array reference here.
3434
3435     $deparser->ambient_pragmas(re => 'eval');
3436
3437
3438 =item warnings
3439
3440 Takes a string, possibly containing a whitespace-separated list of
3441 values. The values "all" and "none" are special, again. It's also
3442 permissible to pass an array reference here.
3443
3444     $deparser->ambient_pragmas(warnings => [qw[void io]]);
3445
3446 If one of the values is the string "FATAL", then all the warnings
3447 in that list will be considered fatal, just as with the B<warnings>
3448 pragma itself. Should you need to specify that some warnings are
3449 fatal, and others are merely enabled, you can pass the B<warnings>
3450 parameter twice:
3451
3452     $deparser->ambient_pragmas(
3453         warnings => 'all',
3454         warnings => [FATAL => qw/void io/],
3455     );
3456
3457 See L<perllexwarn> for more information about lexical warnings.
3458
3459 =item hint_bits
3460
3461 =item warning_bits
3462
3463 These two parameters are used to specify the ambient pragmas in
3464 the format used by the special variables $^H and ${^WARNING_BITS}.
3465
3466 They exist principally so that you can write code like:
3467
3468     { my ($hint_bits, $warning_bits);
3469     BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3470     $deparser->ambient_pragmas (
3471         hint_bits    => $hint_bits,
3472         warning_bits => $warning_bits,
3473         '$['         => 0 + $[
3474     ); }
3475
3476 which specifies that the ambient pragmas are exactly those which
3477 are in scope at the point of calling.
3478
3479 =back
3480
3481 =head2 coderef2text
3482
3483     $body = $deparse->coderef2text(\&func)
3484     $body = $deparse->coderef2text(sub ($$) { ... })
3485
3486 Return source code for the body of a subroutine (a block, optionally
3487 preceded by a prototype in parens), given a reference to the
3488 sub. Because a subroutine can have no names, or more than one name,
3489 this method doesn't return a complete subroutine definition -- if you
3490 want to eval the result, you should prepend "sub subname ", or "sub "
3491 for an anonymous function constructor. Unless the sub was defined in
3492 the main:: package, the code will include a package declaration.
3493
3494 =head1 BUGS
3495
3496 See the 'to do' list at the beginning of the module file.
3497
3498 =head1 AUTHOR
3499
3500 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3501 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3502 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3503 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
3504
3505 =cut