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