ext/B/B/Deparse.pm

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