ext/B/B/Deparse.pm

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