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
2427 sub pp_null {
2428     my $self = shift;
2429     my($op, $cx) = @_;
2430     if (class($op) eq "OP") {
2431         # old value is lost
2432         return $self->{'ex_const'} if $op->targ == OP_CONST;
2433     } elsif ($op->first->name eq "pushmark") {
2434         return $self->pp_list($op, $cx);
2435     } elsif ($op->first->name eq "enter") {
2436         return $self->pp_leave($op, $cx);
2437     } elsif ($op->targ == OP_STRINGIFY) {
2438         return $self->dquote($op, $cx);
2439     } elsif (!null($op->first->sibling) and
2440              $op->first->sibling->name eq "readline" and
2441              $op->first->sibling->flags & OPf_STACKED) {
2442         return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2443                                    . $self->deparse($op->first->sibling, 7),
2444                                    $cx, 7);
2445     } elsif (!null($op->first->sibling) and
2446              $op->first->sibling->name eq "trans" and
2447              $op->first->sibling->flags & OPf_STACKED) {
2448         return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2449                                    . $self->deparse($op->first->sibling, 20),
2450                                    $cx, 20);
2451     } elsif ($op->flags & OPf_SPECIAL && $cx == 0 && !$op->targ) {
2452         return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2453     } else {
2454         return $self->deparse($op->first, $cx);
2455     }
2456 }
2457
2458 sub padname {
2459     my $self = shift;
2460     my $targ = shift;
2461     return $self->padname_sv($targ)->PVX;
2462 }
2463
2464 sub padany {
2465     my $self = shift;
2466     my $op = shift;
2467     return substr($self->padname($op->targ), 1); # skip $/@/%
2468 }
2469
2470 sub pp_padsv {
2471     my $self = shift;
2472     my($op, $cx) = @_;
2473     return $self->maybe_my($op, $cx, $self->padname($op->targ));
2474 }
2475
2476 sub pp_padav { pp_padsv(@_) }
2477 sub pp_padhv { pp_padsv(@_) }
2478
2479 my @threadsv_names;
2480
2481 BEGIN {
2482     @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2483                        "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2484                        "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2485                        "!", "@");
2486 }
2487
2488 sub pp_threadsv {
2489     my $self = shift;
2490     my($op, $cx) = @_;
2491     return $self->maybe_local($op, $cx, "\$" .  $threadsv_names[$op->targ]);
2492 }
2493
2494 sub gv_or_padgv {
2495     my $self = shift;
2496     my $op = shift;
2497     if (class($op) eq "PADOP") {
2498         return $self->padval($op->padix);
2499     } else { # class($op) eq "SVOP"
2500         return $op->gv;
2501     }
2502 }
2503
2504 sub pp_gvsv {
2505     my $self = shift;
2506     my($op, $cx) = @_;
2507     my $gv = $self->gv_or_padgv($op);
2508     return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2509                                  $self->gv_name($gv)));
2510 }
2511
2512 sub pp_gv {
2513     my $self = shift;
2514     my($op, $cx) = @_;
2515     my $gv = $self->gv_or_padgv($op);
2516     return $self->gv_name($gv);
2517 }
2518
2519 sub pp_aelemfast {
2520     my $self = shift;
2521     my($op, $cx) = @_;
2522     my $gv = $self->gv_or_padgv($op);
2523     my $name = $self->gv_name($gv);
2524     $name = $self->{'curstash'}."::$name"
2525         if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2526
2527     return "\$" . $name . "[" .
2528                   ($op->private + $self->{'arybase'}) . "]";
2529 }
2530
2531 sub rv2x {
2532     my $self = shift;
2533     my($op, $cx, $type) = @_;
2534     my $kid = $op->first;
2535     my $str = $self->deparse($kid, 0);
2536     return $self->stash_variable($type, $str) if is_scalar($kid);
2537     return $type ."{$str}";
2538 }
2539
2540 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2541 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2542 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2543
2544 # skip rv2av
2545 sub pp_av2arylen {
2546     my $self = shift;
2547     my($op, $cx) = @_;
2548     if ($op->first->name eq "padav") {
2549         return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2550     } else {
2551         return $self->maybe_local($op, $cx,
2552                                   $self->rv2x($op->first, $cx, '$#'));
2553     }
2554 }
2555
2556 # skip down to the old, ex-rv2cv
2557 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
2558
2559 sub pp_rv2av {
2560     my $self = shift;
2561     my($op, $cx) = @_;
2562     my $kid = $op->first;
2563     if ($kid->name eq "const") { # constant list
2564         my $av = $self->const_sv($kid);
2565         return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2566     } else {
2567         return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2568     }
2569  }
2570
2571 sub is_subscriptable {
2572     my $op = shift;
2573     if ($op->name =~ /^[ahg]elem/) {
2574         return 1;
2575     } elsif ($op->name eq "entersub") {
2576         my $kid = $op->first;
2577         return 0 unless null $kid->sibling;
2578         $kid = $kid->first;
2579         $kid = $kid->sibling until null $kid->sibling;
2580         return 0 if is_scope($kid);
2581         $kid = $kid->first;
2582         return 0 if $kid->name eq "gv";
2583         return 0 if is_scalar($kid);
2584         return is_subscriptable($kid);
2585     } else {
2586         return 0;
2587     }
2588 }
2589
2590 sub elem {
2591     my $self = shift;
2592     my ($op, $cx, $left, $right, $padname) = @_;
2593     my($array, $idx) = ($op->first, $op->first->sibling);
2594     unless ($array->name eq $padname) { # Maybe this has been fixed
2595         $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2596     }
2597     if ($array->name eq $padname) {
2598         $array = $self->padany($array);
2599     } elsif (is_scope($array)) { # ${expr}[0]
2600         $array = "{" . $self->deparse($array, 0) . "}";
2601     } elsif ($array->name eq "gv") {
2602         $array = $self->gv_name($self->gv_or_padgv($array));
2603         if ($array !~ /::/) {
2604             my $prefix = ($left eq '[' ? '@' : '%');
2605             $array = $self->{curstash}.'::'.$array
2606                 if $self->lex_in_scope($prefix . $array);
2607         }
2608     } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2609         $array = $self->deparse($array, 24);
2610     } else {
2611         # $x[20][3]{hi} or expr->[20]
2612         my $arrow = is_subscriptable($array) ? "" : "->";
2613         return $self->deparse($array, 24) . $arrow .
2614             $left . $self->deparse($idx, 1) . $right;
2615     }
2616     $idx = $self->deparse($idx, 1);
2617
2618     # Outer parens in an array index will confuse perl
2619     # if we're interpolating in a regular expression, i.e.
2620     # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2621     #
2622     # If $self->{parens}, then an initial '(' will
2623     # definitely be paired with a final ')'. If
2624     # !$self->{parens}, the misleading parens won't
2625     # have been added in the first place.
2626     #
2627     # [You might think that we could get "(...)...(...)"
2628     # where the initial and final parens do not match
2629     # each other. But we can't, because the above would
2630     # only happen if there's an infix binop between the
2631     # two pairs of parens, and *that* means that the whole
2632     # expression would be parenthesized as well.]
2633     #
2634     $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2635
2636     return "\$" . $array . $left . $idx . $right;
2637 }
2638
2639 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2640 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2641
2642 sub pp_gelem {
2643     my $self = shift;
2644     my($op, $cx) = @_;
2645     my($glob, $part) = ($op->first, $op->last);
2646     $glob = $glob->first; # skip rv2gv
2647     $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2648     my $scope = is_scope($glob);
2649     $glob = $self->deparse($glob, 0);
2650     $part = $self->deparse($part, 1);
2651     return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2652 }
2653
2654 sub slice {
2655     my $self = shift;
2656     my ($op, $cx, $left, $right, $regname, $padname) = @_;
2657     my $last;
2658     my(@elems, $kid, $array, $list);
2659     if (class($op) eq "LISTOP") {
2660         $last = $op->last;
2661     } else { # ex-hslice inside delete()
2662         for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2663         $last = $kid;
2664     }
2665     $array = $last;
2666     $array = $array->first
2667         if $array->name eq $regname or $array->name eq "null";
2668     if (is_scope($array)) {
2669         $array = "{" . $self->deparse($array, 0) . "}";
2670     } elsif ($array->name eq $padname) {
2671         $array = $self->padany($array);
2672     } else {
2673         $array = $self->deparse($array, 24);
2674     }
2675     $kid = $op->first->sibling; # skip pushmark
2676     if ($kid->name eq "list") {
2677         $kid = $kid->first->sibling; # skip list, pushmark
2678         for (; !null $kid; $kid = $kid->sibling) {
2679             push @elems, $self->deparse($kid, 6);
2680         }
2681         $list = join(", ", @elems);
2682     } else {
2683         $list = $self->deparse($kid, 1);
2684     }
2685     return "\@" . $array . $left . $list . $right;
2686 }
2687
2688 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2689 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2690
2691 sub pp_lslice {
2692     my $self = shift;
2693     my($op, $cx) = @_;
2694     my $idx = $op->first;
2695     my $list = $op->last;
2696     my(@elems, $kid);
2697     $list = $self->deparse($list, 1);
2698     $idx = $self->deparse($idx, 1);
2699     return "($list)" . "[$idx]";
2700 }
2701
2702 sub want_scalar {
2703     my $op = shift;
2704     return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2705 }
2706
2707 sub want_list {
2708     my $op = shift;
2709     return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2710 }
2711
2712 sub method {
2713     my $self = shift;
2714     my($op, $cx) = @_;
2715     my $kid = $op->first->sibling; # skip pushmark
2716     my($meth, $obj, @exprs);
2717     if ($kid->name eq "list" and want_list $kid) {
2718         # When an indirect object isn't a bareword but the args are in
2719         # parens, the parens aren't part of the method syntax (the LLAFR
2720         # doesn't apply), but they make a list with OPf_PARENS set that
2721         # doesn't get flattened by the append_elem that adds the method,
2722         # making a (object, arg1, arg2, ...) list where the object
2723         # usually is. This can be distinguished from
2724         # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2725         # object) because in the later the list is in scalar context
2726         # as the left side of -> always is, while in the former
2727         # the list is in list context as method arguments always are.
2728         # (Good thing there aren't method prototypes!)
2729         $meth = $kid->sibling;
2730         $kid = $kid->first->sibling; # skip pushmark
2731         $obj = $kid;
2732         $kid = $kid->sibling;
2733         for (; not null $kid; $kid = $kid->sibling) {
2734             push @exprs, $self->deparse($kid, 6);
2735         }
2736     } else {
2737         $obj = $kid;
2738         $kid = $kid->sibling;
2739         for (; not null $kid->sibling; $kid = $kid->sibling) {
2740             push @exprs, $self->deparse($kid, 6);
2741         }
2742         $meth = $kid;
2743     }
2744     $obj = $self->deparse($obj, 24);
2745     if ($meth->name eq "method_named") {
2746         $meth = $self->const_sv($meth)->PV;
2747     } else {
2748         $meth = $meth->first;
2749         if ($meth->name eq "const") {
2750             # As of 5.005_58, this case is probably obsoleted by the
2751             # method_named case above
2752             $meth = $self->const_sv($meth)->PV; # needs to be bare
2753         } else {
2754             $meth = $self->deparse($meth, 1);
2755         }
2756     }
2757     my $args = join(", ", @exprs);
2758     $kid = $obj . "->" . $meth;
2759     if (length $args) {
2760         return $kid . "(" . $args . ")"; # parens mandatory
2761     } else {
2762         return $kid;
2763     }
2764 }
2765
2766 # returns "&" if the prototype doesn't match the args,
2767 # or ("", $args_after_prototype_demunging) if it does.
2768 sub check_proto {
2769     my $self = shift;
2770     my($proto, @args) = @_;
2771     my($arg, $real);
2772     my $doneok = 0;
2773     my @reals;
2774     # An unbackslashed @ or % gobbles up the rest of the args
2775     $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2776     while ($proto) {
2777         $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2778         my $chr = $1;
2779         if ($chr eq "") {
2780             return "&" if @args;
2781         } elsif ($chr eq ";") {
2782             $doneok = 1;
2783         } elsif ($chr eq "@" or $chr eq "%") {
2784             push @reals, map($self->deparse($_, 6), @args);
2785             @args = ();
2786         } else {
2787             $arg = shift @args;
2788             last unless $arg;
2789             if ($chr eq "\$") {
2790                 if (want_scalar $arg) {
2791                     push @reals, $self->deparse($arg, 6);
2792                 } else {
2793                     return "&";
2794                 }
2795             } elsif ($chr eq "&") {
2796                 if ($arg->name =~ /^(s?refgen|undef)$/) {
2797                     push @reals, $self->deparse($arg, 6);
2798                 } else {
2799                     return "&";
2800                 }
2801             } elsif ($chr eq "*") {
2802                 if ($arg->name =~ /^s?refgen$/
2803                     and $arg->first->first->name eq "rv2gv")
2804                   {
2805                       $real = $arg->first->first; # skip refgen, null
2806                       if ($real->first->name eq "gv") {
2807                           push @reals, $self->deparse($real, 6);
2808                       } else {
2809                           push @reals, $self->deparse($real->first, 6);
2810                       }
2811                   } else {
2812                       return "&";
2813                   }
2814             } elsif (substr($chr, 0, 1) eq "\\") {
2815                 $chr = substr($chr, 1);
2816                 if ($arg->name =~ /^s?refgen$/ and
2817                     !null($real = $arg->first) and
2818                     ($chr eq "\$" && is_scalar($real->first)
2819                      or ($chr eq "\@"
2820                          && $real->first->sibling->name
2821                          =~ /^(rv2|pad)av$/)
2822                      or ($chr eq "%"
2823                          && $real->first->sibling->name
2824                          =~ /^(rv2|pad)hv$/)
2825                      #or ($chr eq "&" # This doesn't work
2826                      #   && $real->first->name eq "rv2cv")
2827                      or ($chr eq "*"
2828                          && $real->first->name eq "rv2gv")))
2829                   {
2830                       push @reals, $self->deparse($real, 6);
2831                   } else {
2832                       return "&";
2833                   }
2834             }
2835        }
2836     }
2837     return "&" if $proto and !$doneok; # too few args and no `;'
2838     return "&" if @args;               # too many args
2839     return ("", join ", ", @reals);
2840 }
2841
2842 sub pp_entersub {
2843     my $self = shift;
2844     my($op, $cx) = @_;
2845     return $self->method($op, $cx) unless null $op->first->sibling;
2846     my $prefix = "";
2847     my $amper = "";
2848     my($kid, @exprs);
2849     if ($op->flags & OPf_SPECIAL) {
2850         $prefix = "do ";
2851     } elsif ($op->private & OPpENTERSUB_AMPER) {
2852         $amper = "&";
2853     }
2854     $kid = $op->first;
2855     $kid = $kid->first->sibling; # skip ex-list, pushmark
2856     for (; not null $kid->sibling; $kid = $kid->sibling) {
2857         push @exprs, $kid;
2858     }
2859     my $simple = 0;
2860     my $proto = undef;
2861     if (is_scope($kid)) {
2862         $amper = "&";
2863         $kid = "{" . $self->deparse($kid, 0) . "}";
2864     } elsif ($kid->first->name eq "gv") {
2865         my $gv = $self->gv_or_padgv($kid->first);
2866         if (class($gv->CV) ne "SPECIAL") {
2867             $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2868         }
2869         $simple = 1; # only calls of named functions can be prototyped
2870         $kid = $self->deparse($kid, 24);
2871     } elsif (is_scalar $kid->first) {
2872         $amper = "&";
2873         $kid = $self->deparse($kid, 24);
2874     } else {
2875         $prefix = "";
2876         my $arrow = is_subscriptable($kid->first) ? "" : "->";
2877         $kid = $self->deparse($kid, 24) . $arrow;
2878     }
2879
2880     # Doesn't matter how many prototypes there are, if
2881     # they haven't happened yet!
2882     my $declared = exists $self->{'subs_declared'}{$kid};
2883     if (!$declared && defined($proto)) {
2884         # Avoid "too early to check prototype" warning
2885         ($amper, $proto) = ('&');
2886     }
2887
2888     my $args;
2889     if ($declared and defined $proto and not $amper) {
2890         ($amper, $args) = $self->check_proto($proto, @exprs);
2891         if ($amper eq "&") {
2892             $args = join(", ", map($self->deparse($_, 6), @exprs));
2893         }
2894     } else {
2895         $args = join(", ", map($self->deparse($_, 6), @exprs));
2896     }
2897     if ($prefix or $amper) {
2898         if ($op->flags & OPf_STACKED) {
2899             return $prefix . $amper . $kid . "(" . $args . ")";
2900         } else {
2901             return $prefix . $amper. $kid;
2902         }
2903     } else {
2904         # glob() invocations can be translated into calls of
2905         # CORE::GLOBAL::glob with an second parameter, a number.
2906         # Reverse this.
2907         if ($kid eq "CORE::GLOBAL::glob") {
2908             $kid = "glob";
2909             $args =~ s/\s*,[^,]+$//;
2910         }
2911
2912         # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2913         # so it must have been translated from a keyword call. Translate
2914         # it back.
2915         $kid =~ s/^CORE::GLOBAL:://;
2916
2917         if (!$declared) {
2918             return "$kid(" . $args . ")";
2919         } elsif (defined $proto and $proto eq "") {
2920             return $kid;
2921         } elsif (defined $proto and $proto eq "\$" and is_scalar($exprs[0])) {
2922             return $self->maybe_parens_func($kid, $args, $cx, 16);
2923         } elsif (defined($proto) && $proto or $simple) {
2924             return $self->maybe_parens_func($kid, $args, $cx, 5);
2925         } else {
2926             return "$kid(" . $args . ")";
2927         }
2928     }
2929 }
2930
2931 sub pp_enterwrite { unop(@_, "write") }
2932
2933 # escape things that cause interpolation in double quotes,
2934 # but not character escapes
2935 sub uninterp {
2936     my($str) = @_;
2937     $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
2938     return $str;
2939 }
2940
2941 # the same, but treat $|, $), $( and $ at the end of the string differently
2942 sub re_uninterp {
2943     my($str) = @_;
2944
2945     use re "eval";
2946     # Matches any string which is balanced with respect to {braces}
2947     my $bal = qr(
2948       (?:
2949         [^\\{}]
2950       | \\\\
2951       | \\[{}]
2952       | \{(??{$bal})\}
2953       )*
2954     )x;
2955
2956     $str =~ s/
2957           ( ^|\G                  # $1
2958           | [^\\]
2959           )
2960
2961           (                       # $2
2962             (?:\\\\)*
2963           )
2964
2965           (                       # $3
2966             (\(\?\??\{$bal\}\))   # $4
2967           | [\$\@]
2968             (?!\||\)|\(|$)
2969           | \\[uUlLQE]
2970           )
2971
2972         /length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
2973
2974     return $str;
2975 }
2976
2977 # character escapes, but not delimiters that might need to be escaped
2978 sub escape_str { # ASCII, UTF8
2979     my($str) = @_;
2980     $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
2981     $str =~ s/\a/\\a/g;
2982 #    $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2983     $str =~ s/\t/\\t/g;
2984     $str =~ s/\n/\\n/g;
2985     $str =~ s/\e/\\e/g;
2986     $str =~ s/\f/\\f/g;
2987     $str =~ s/\r/\\r/g;
2988     $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2989     $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2990     return $str;
2991 }
2992
2993 # Don't do this for regexen
2994 sub unback {
2995     my($str) = @_;
2996     $str =~ s/\\/\\\\/g;
2997     return $str;
2998 }
2999
3000 # Remove backslashes which precede literal control characters,
3001 # to avoid creating ambiguity when we escape the latter.
3002 sub re_unback {
3003     my($str) = @_;
3004
3005     # the insane complexity here is due to the behaviour of "\c\"
3006     $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
3007     return $str;
3008 }
3009
3010 sub balanced_delim {
3011     my($str) = @_;
3012     my @str = split //, $str;
3013     my($ar, $open, $close, $fail, $c, $cnt);
3014     for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3015         ($open, $close) = @$ar;
3016         $fail = 0; $cnt = 0;
3017         for $c (@str) {
3018             if ($c eq $open) {
3019                 $cnt++;
3020             } elsif ($c eq $close) {
3021                 $cnt--;
3022                 if ($cnt < 0) {
3023                     # qq()() isn't ")("
3024                     $fail = 1;
3025                     last;
3026                 }
3027             }
3028         }
3029         $fail = 1 if $cnt != 0;
3030         return ($open, "$open$str$close") if not $fail;
3031     }
3032     return ("", $str);
3033 }
3034
3035 sub single_delim {
3036     my($q, $default, $str) = @_;
3037     return "$default$str$default" if $default and index($str, $default) == -1;
3038     my($succeed, $delim);
3039     ($succeed, $str) = balanced_delim($str);
3040     return "$q$str" if $succeed;
3041     for $delim ('/', '"', '#') {
3042         return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3043     }
3044     if ($default) {
3045         $str =~ s/$default/\\$default/g;
3046         return "$default$str$default";
3047     } else {
3048         $str =~ s[/][\\/]g;
3049         return "$q/$str/";
3050     }
3051 }
3052
3053 sub const {
3054     my $sv = shift;
3055     if (class($sv) eq "SPECIAL") {
3056         return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
3057     } elsif (class($sv) eq "NULL") {
3058        return 'undef';
3059     } elsif ($sv->FLAGS & SVf_IOK) {
3060         return $sv->int_value;
3061     } elsif ($sv->FLAGS & SVf_NOK) {
3062         # try the default stringification
3063         my $r = "".$sv->NV;
3064         if ($r =~ /e/) {
3065             # If it's in scientific notation, we might have lost information
3066             return sprintf("%.20e", $sv->NV);
3067         }
3068         return $r;
3069     } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3070         return "\\(" . const($sv->RV) . ")"; # constant folded
3071     } elsif ($sv->FLAGS & SVf_POK) {
3072         my $str = $sv->PV;
3073         if ($str =~ /[^ -~]/) { # ASCII for non-printing
3074             return single_delim("qq", '"', uninterp escape_str unback $str);
3075         } else {
3076             return single_delim("q", "'", unback $str);
3077         }
3078     } else {
3079         return "undef";
3080     }
3081 }
3082
3083 sub const_sv {
3084     my $self = shift;
3085     my $op = shift;
3086     my $sv = $op->sv;
3087     # the constant could be in the pad (under useithreads)
3088     $sv = $self->padval($op->targ) unless $$sv;
3089     return $sv;
3090 }
3091
3092 sub pp_const {
3093     my $self = shift;
3094     my($op, $cx) = @_;
3095     if ($op->private & OPpCONST_ARYBASE) {
3096         return '$[';
3097     }
3098 #    if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3099 #       return $self->const_sv($op)->PV;
3100 #    }
3101     my $sv = $self->const_sv($op);
3102 #    return const($sv);
3103     my $c = const $sv;
3104     return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
3105 }
3106
3107 sub dq {
3108     my $self = shift;
3109     my $op = shift;
3110     my $type = $op->name;
3111     if ($type eq "const") {
3112         return '$[' if $op->private & OPpCONST_ARYBASE;
3113         return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3114     } elsif ($type eq "concat") {
3115         my $first = $self->dq($op->first);
3116         my $last  = $self->dq($op->last);
3117
3118         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3119         ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3120             $first =~ s/([\$@])\^$/${1}{^}/)  # "${^}W" etc
3121             || ($last =~ /^[{\[\w_]/ &&
3122                 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3123
3124         return $first . $last;
3125     } elsif ($type eq "uc") {
3126         return '\U' . $self->dq($op->first->sibling) . '\E';
3127     } elsif ($type eq "lc") {
3128         return '\L' . $self->dq($op->first->sibling) . '\E';
3129     } elsif ($type eq "ucfirst") {
3130         return '\u' . $self->dq($op->first->sibling);
3131     } elsif ($type eq "lcfirst") {
3132         return '\l' . $self->dq($op->first->sibling);
3133     } elsif ($type eq "quotemeta") {
3134         return '\Q' . $self->dq($op->first->sibling) . '\E';
3135     } elsif ($type eq "join") {
3136         return $self->deparse($op->last, 26); # was join($", @ary)
3137     } else {
3138         return $self->deparse($op, 26);
3139     }
3140 }
3141
3142 sub pp_backtick {
3143     my $self = shift;
3144     my($op, $cx) = @_;
3145     # skip pushmark
3146     return single_delim("qx", '`', $self->dq($op->first->sibling));
3147 }
3148
3149 sub dquote {
3150     my $self = shift;
3151     my($op, $cx) = @_;
3152     my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3153     return $self->deparse($kid, $cx) if $self->{'unquote'};
3154     $self->maybe_targmy($kid, $cx,
3155                         sub {single_delim("qq", '"', $self->dq($_[1]))});
3156 }
3157
3158 # OP_STRINGIFY is a listop, but it only ever has one arg
3159 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3160
3161 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3162 # note that tr(from)/to/ is OK, but not tr/from/(to)
3163 sub double_delim {
3164     my($from, $to) = @_;
3165     my($succeed, $delim);
3166     if ($from !~ m[/] and $to !~ m[/]) {
3167         return "/$from/$to/";
3168     } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3169         if (($succeed, $to) = balanced_delim($to) and $succeed) {
3170             return "$from$to";
3171         } else {
3172             for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3173                 return "$from$delim$to$delim" if index($to, $delim) == -1;
3174             }
3175             $to =~ s[/][\\/]g;
3176             return "$from/$to/";
3177         }
3178     } else {
3179         for $delim ('/', '"', '#') { # note no '
3180             return "$delim$from$delim$to$delim"
3181                 if index($to . $from, $delim) == -1;
3182         }
3183         $from =~ s[/][\\/]g;
3184         $to =~ s[/][\\/]g;
3185         return "/$from/$to/";
3186     }
3187 }
3188
3189 # Only used by tr///, so backslashes hyphens
3190 sub pchr { # ASCII
3191     my($n) = @_;
3192     if ($n == ord '\\') {
3193         return '\\\\';
3194     } elsif ($n == ord "-") {
3195         return "\\-";
3196     } elsif ($n >= ord(' ') and $n <= ord('~')) {
3197         return chr($n);
3198     } elsif ($n == ord "\a") {
3199         return '\\a';
3200     } elsif ($n == ord "\b") {
3201         return '\\b';
3202     } elsif ($n == ord "\t") {
3203         return '\\t';
3204     } elsif ($n == ord "\n") {
3205         return '\\n';
3206     } elsif ($n == ord "\e") {
3207         return '\\e';
3208     } elsif ($n == ord "\f") {
3209         return '\\f';
3210     } elsif ($n == ord "\r") {
3211         return '\\r';
3212     } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3213         return '\\c' . chr(ord("@") + $n);
3214     } else {
3215 #       return '\x' . sprintf("%02x", $n);
3216         return '\\' . sprintf("%03o", $n);
3217     }
3218 }
3219
3220 sub collapse {
3221     my(@chars) = @_;
3222     my($str, $c, $tr) = ("");
3223     for ($c = 0; $c < @chars; $c++) {
3224         $tr = $chars[$c];
3225         $str .= pchr($tr);
3226         if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3227             $chars[$c + 2] == $tr + 2)
3228         {
3229             for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3230               {}
3231             $str .= "-";
3232             $str .= pchr($chars[$c]);
3233         }
3234     }
3235     return $str;
3236 }
3237
3238 sub tr_decode_byte {
3239     my($table, $flags) = @_;
3240     my(@table) = unpack("s*", $table);
3241     splice @table, 0x100, 1;   # Number of subsequent elements
3242     my($c, $tr, @from, @to, @delfrom, $delhyphen);
3243     if ($table[ord "-"] != -1 and
3244         $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3245     {
3246         $tr = $table[ord "-"];
3247         $table[ord "-"] = -1;
3248         if ($tr >= 0) {
3249             @from = ord("-");
3250             @to = $tr;
3251         } else { # -2 ==> delete
3252             $delhyphen = 1;
3253         }
3254     }
3255     for ($c = 0; $c < @table; $c++) {
3256         $tr = $table[$c];
3257         if ($tr >= 0) {
3258             push @from, $c; push @to, $tr;
3259         } elsif ($tr == -2) {
3260             push @delfrom, $c;
3261         }
3262     }
3263     @from = (@from, @delfrom);
3264     if ($flags & OPpTRANS_COMPLEMENT) {
3265         my @newfrom = ();
3266         my %from;
3267         @from{@from} = (1) x @from;
3268         for ($c = 0; $c < 256; $c++) {
3269             push @newfrom, $c unless $from{$c};
3270         }
3271         @from = @newfrom;
3272     }
3273     unless ($flags & OPpTRANS_DELETE || !@to) {
3274         pop @to while $#to and $to[$#to] == $to[$#to -1];
3275     }
3276     my($from, $to);
3277     $from = collapse(@from);
3278     $to = collapse(@to);
3279     $from .= "-" if $delhyphen;
3280     return ($from, $to);
3281 }
3282
3283 sub tr_chr {
3284     my $x = shift;
3285     if ($x == ord "-") {
3286         return "\\-";
3287     } elsif ($x == ord "\\") {
3288         return "\\\\";
3289     } else {
3290         return chr $x;
3291     }
3292 }
3293
3294 # XXX This doesn't yet handle all cases correctly either
3295
3296 sub tr_decode_utf8 {
3297     my($swash_hv, $flags) = @_;
3298     my %swash = $swash_hv->ARRAY;
3299     my $final = undef;
3300     $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3301     my $none = $swash{"NONE"}->IV;
3302     my $extra = $none + 1;
3303     my(@from, @delfrom, @to);
3304     my $line;
3305     foreach $line (split /\n/, $swash{'LIST'}->PV) {
3306         my($min, $max, $result) = split(/\t/, $line);
3307         $min = hex $min;
3308         if (length $max) {
3309             $max = hex $max;
3310         } else {
3311             $max = $min;
3312         }
3313         $result = hex $result;
3314         if ($result == $extra) {
3315             push @delfrom, [$min, $max];
3316         } else {
3317             push @from, [$min, $max];
3318             push @to, [$result, $result + $max - $min];
3319         }
3320     }
3321     for my $i (0 .. $#from) {
3322         if ($from[$i][0] == ord '-') {
3323             unshift @from, splice(@from, $i, 1);
3324             unshift @to, splice(@to, $i, 1);
3325             last;
3326         } elsif ($from[$i][1] == ord '-') {
3327             $from[$i][1]--;
3328             $to[$i][1]--;
3329             unshift @from, ord '-';
3330             unshift @to, ord '-';
3331             last;
3332         }
3333     }
3334     for my $i (0 .. $#delfrom) {
3335         if ($delfrom[$i][0] == ord '-') {
3336             push @delfrom, splice(@delfrom, $i, 1);
3337             last;
3338         } elsif ($delfrom[$i][1] == ord '-') {
3339             $delfrom[$i][1]--;
3340             push @delfrom, ord '-';
3341             last;
3342         }
3343     }
3344     if (defined $final and $to[$#to][1] != $final) {
3345         push @to, [$final, $final];
3346     }
3347     push @from, @delfrom;
3348     if ($flags & OPpTRANS_COMPLEMENT) {
3349         my @newfrom;
3350         my $next = 0;
3351         for my $i (0 .. $#from) {
3352             push @newfrom, [$next, $from[$i][0] - 1];
3353             $next = $from[$i][1] + 1;
3354         }
3355         @from = ();
3356         for my $range (@newfrom) {
3357             if ($range->[0] <= $range->[1]) {
3358                 push @from, $range;
3359             }
3360         }
3361     }
3362     my($from, $to, $diff);
3363     for my $chunk (@from) {
3364         $diff = $chunk->[1] - $chunk->[0];
3365         if ($diff > 1) {
3366             $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3367         } elsif ($diff == 1) {
3368             $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3369         } else {
3370             $from .= tr_chr($chunk->[0]);
3371         }
3372     }
3373     for my $chunk (@to) {
3374         $diff = $chunk->[1] - $chunk->[0];
3375         if ($diff > 1) {
3376             $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3377         } elsif ($diff == 1) {
3378             $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3379         } else {
3380             $to .= tr_chr($chunk->[0]);
3381         }
3382     }
3383     #$final = sprintf("%04x", $final) if defined $final;
3384     #$none = sprintf("%04x", $none) if defined $none;
3385     #$extra = sprintf("%04x", $extra) if defined $extra;
3386     #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3387     #print STDERR $swash{'LIST'}->PV;
3388     return (escape_str($from), escape_str($to));
3389 }
3390
3391 sub pp_trans {
3392     my $self = shift;
3393     my($op, $cx) = @_;
3394     my($from, $to);
3395     if (class($op) eq "PVOP") {
3396         ($from, $to) = tr_decode_byte($op->pv, $op->private);
3397     } else { # class($op) eq "SVOP"
3398         ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3399     }
3400     my $flags = "";
3401     $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3402     $flags .= "d" if $op->private & OPpTRANS_DELETE;
3403     $to = "" if $from eq $to and $flags eq "";
3404     $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3405     return "tr" . double_delim($from, $to) . $flags;
3406 }
3407
3408 # Like dq(), but different
3409 sub re_dq {
3410     my $self = shift;
3411     my $op = shift;
3412     my $type = $op->name;
3413     if ($type eq "const") {
3414         return '$[' if $op->private & OPpCONST_ARYBASE;
3415         return re_uninterp(escape_str(re_unback($self->const_sv($op)->as_string)));
3416     } elsif ($type eq "concat") {
3417         my $first = $self->re_dq($op->first);
3418         my $last  = $self->re_dq($op->last);
3419         # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3420         if ($last =~ /^[A-Z\\\^\[\]_?]/) {
3421             $first =~ s/([\$@])\^$/${1}{^}/;
3422         }
3423         elsif ($last =~ /^[{\[\w]/) {
3424             $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
3425         }
3426         return $first . $last;
3427     } elsif ($type eq "uc") {
3428         return '\U' . $self->re_dq($op->first->sibling) . '\E';
3429     } elsif ($type eq "lc") {
3430         return '\L' . $self->re_dq($op->first->sibling) . '\E';
3431     } elsif ($type eq "ucfirst") {
3432         return '\u' . $self->re_dq($op->first->sibling);
3433     } elsif ($type eq "lcfirst") {
3434         return '\l' . $self->re_dq($op->first->sibling);
3435     } elsif ($type eq "quotemeta") {
3436         return '\Q' . $self->re_dq($op->first->sibling) . '\E';
3437     } elsif ($type eq "join") {
3438         return $self->deparse($op->last, 26); # was join($", @ary)
3439     } else {
3440         return $self->deparse($op, 26);
3441     }
3442 }
3443
3444 sub pp_regcomp {
3445     my $self = shift;
3446     my($op, $cx) = @_;
3447     my $kid = $op->first;
3448     $kid = $kid->first if $kid->name eq "regcmaybe";
3449     $kid = $kid->first if $kid->name eq "regcreset";
3450     return $self->re_dq($kid);
3451 }
3452
3453 # osmic acid -- see osmium tetroxide
3454
3455 my %matchwords;
3456 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3457     'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3458     'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3459
3460 sub matchop {
3461     my $self = shift;
3462     my($op, $cx, $name, $delim) = @_;
3463     my $kid = $op->first;
3464     my ($binop, $var, $re) = ("", "", "");
3465     if ($op->flags & OPf_STACKED) {
3466         $binop = 1;
3467         $var = $self->deparse($kid, 20);
3468         $kid = $kid->sibling;
3469     }
3470     if (null $kid) {
3471         $re = re_uninterp(escape_str(re_unback($op->precomp)));
3472     } else {
3473         $re = $self->deparse($kid, 1);
3474     }
3475     my $flags = "";
3476     $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3477     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3478     $flags .= "i" if $op->pmflags & PMf_FOLD;
3479     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3480     $flags .= "o" if $op->pmflags & PMf_KEEP;
3481     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3482     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3483     $flags = $matchwords{$flags} if $matchwords{$flags};
3484     if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3485         $re =~ s/\?/\\?/g;
3486         $re = "?$re?";
3487     } else {
3488         $re = single_delim($name, $delim, $re);
3489     }
3490     $re = $re . $flags;
3491     if ($binop) {
3492         return $self->maybe_parens("$var =~ $re", $cx, 20);
3493     } else {
3494         return $re;
3495     }
3496 }
3497
3498 sub pp_match { matchop(@_, "m", "/") }
3499 sub pp_pushre { matchop(@_, "m", "/") }
3500 sub pp_qr { matchop(@_, "qr", "") }
3501
3502 sub pp_split {
3503     my $self = shift;
3504     my($op, $cx) = @_;
3505     my($kid, @exprs, $ary, $expr);
3506     $kid = $op->first;
3507     if ($ {$kid->pmreplroot}) {
3508         $ary = $self->stash_variable('@', $self->gv_name($kid->pmreplroot));
3509     }
3510     for (; !null($kid); $kid = $kid->sibling) {
3511         push @exprs, $self->deparse($kid, 6);
3512     }
3513
3514     # handle special case of split(), and split(" ") that compiles to /\s+/
3515     $kid = $op->first;
3516     if ($kid->flags & OPf_SPECIAL
3517         && $exprs[0] eq '/\\s+/'
3518         && $kid->pmflags & PMf_SKIPWHITE ) {
3519             $exprs[0] = '" "';
3520     }
3521
3522     $expr = "split(" . join(", ", @exprs) . ")";
3523     if ($ary) {
3524         return $self->maybe_parens("$ary = $expr", $cx, 7);
3525     } else {
3526         return $expr;
3527     }
3528 }
3529
3530 # oxime -- any of various compounds obtained chiefly by the action of
3531 # hydroxylamine on aldehydes and ketones and characterized by the
3532 # bivalent grouping C=NOH [Webster's Tenth]
3533
3534 my %substwords;
3535 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3536     'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3537     'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3538     'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3539
3540 sub pp_subst {
3541     my $self = shift;
3542     my($op, $cx) = @_;
3543     my $kid = $op->first;
3544     my($binop, $var, $re, $repl) = ("", "", "", "");
3545     if ($op->flags & OPf_STACKED) {
3546         $binop = 1;
3547         $var = $self->deparse($kid, 20);
3548         $kid = $kid->sibling;
3549     }
3550     my $flags = "";
3551     if (null($op->pmreplroot)) {
3552         $repl = $self->dq($kid);
3553         $kid = $kid->sibling;
3554     } else {
3555         $repl = $op->pmreplroot->first; # skip substcont
3556         while ($repl->name eq "entereval") {
3557             $repl = $repl->first;
3558             $flags .= "e";
3559         }
3560         if ($op->pmflags & PMf_EVAL) {
3561             $repl = $self->deparse($repl, 0);
3562         } else {
3563             $repl = $self->dq($repl);
3564         }
3565     }
3566     if (null $kid) {
3567         $re = re_uninterp(escape_str(re_unback($op->precomp)));
3568     } else {
3569         $re = $self->deparse($kid, 1);
3570     }
3571     $flags .= "e" if $op->pmflags & PMf_EVAL;
3572     $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3573     $flags .= "i" if $op->pmflags & PMf_FOLD;
3574     $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3575     $flags .= "o" if $op->pmflags & PMf_KEEP;
3576     $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3577     $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3578     $flags = $substwords{$flags} if $substwords{$flags};
3579     if ($binop) {
3580         return $self->maybe_parens("$var =~ s"
3581                                    . double_delim($re, $repl) . $flags,
3582                                    $cx, 20);
3583     } else {
3584         return "s". double_delim($re, $repl) . $flags;
3585     }
3586 }
3587
3588 1;
3589 __END__
3590
3591 =head1 NAME
3592
3593 B::Deparse - Perl compiler backend to produce perl code
3594
3595 =head1 SYNOPSIS
3596
3597 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3598         [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3599
3600 =head1 DESCRIPTION
3601
3602 B::Deparse is a backend module for the Perl compiler that generates
3603 perl source code, based on the internal compiled structure that perl
3604 itself creates after parsing a program. The output of B::Deparse won't
3605 be exactly the same as the original source, since perl doesn't keep
3606 track of comments or whitespace, and there isn't a one-to-one
3607 correspondence between perl's syntactical constructions and their
3608 compiled form, but it will often be close. When you use the B<-p>
3609 option, the output also includes parentheses even when they are not
3610 required by precedence, which can make it easy to see if perl is
3611 parsing your expressions the way you intended.
3612
3613 Please note that this module is mainly new and untested code and is
3614 still under development, so it may change in the future.
3615
3616 =head1 OPTIONS
3617
3618 As with all compiler backend options, these must follow directly after
3619 the '-MO=Deparse', separated by a comma but not any white space.
3620
3621 =over 4
3622
3623 =item B<-l>
3624
3625 Add '#line' declarations to the output based on the line and file
3626 locations of the original code.
3627
3628 =item B<-p>
3629
3630 Print extra parentheses. Without this option, B::Deparse includes
3631 parentheses in its output only when they are needed, based on the
3632 structure of your program. With B<-p>, it uses parentheses (almost)
3633 whenever they would be legal. This can be useful if you are used to
3634 LISP, or if you want to see how perl parses your input. If you say
3635
3636     if ($var & 0x7f == 65) {print "Gimme an A!"}
3637     print ($which ? $a : $b), "\n";
3638     $name = $ENV{USER} or "Bob";
3639
3640 C<B::Deparse,-p> will print
3641
3642     if (($var & 0)) {
3643         print('Gimme an A!')
3644     };
3645     (print(($which ? $a : $b)), '???');
3646     (($name = $ENV{'USER'}) or '???')
3647
3648 which probably isn't what you intended (the C<'???'> is a sign that
3649 perl optimized away a constant value).
3650
3651 =item B<-q>
3652
3653 Expand double-quoted strings into the corresponding combinations of
3654 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3655 instance, print
3656
3657     print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3658
3659 as
3660
3661     print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3662           . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3663
3664 Note that the expanded form represents the way perl handles such
3665 constructions internally -- this option actually turns off the reverse
3666 translation that B::Deparse usually does. On the other hand, note that
3667 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3668 of $y into a string before doing the assignment.
3669
3670 =item B<-f>I<FILE>
3671
3672 Normally, B::Deparse deparses the main code of a program, and all the subs
3673 defined in the same file. To include subs defined in other files, pass the
3674 B<-f> option with the filename. You can pass the B<-f> option several times, to
3675 include more than one secondary file.  (Most of the time you don't want to
3676 use it at all.)  You can also use this option to include subs which are
3677 defined in the scope of a B<#line> directive with two parameters.
3678
3679 =item B<-s>I<LETTERS>
3680
3681 Tweak the style of B::Deparse's output. The letters should follow
3682 directly after the 's', with no space or punctuation. The following
3683 options are available:
3684
3685 =over 4
3686
3687 =item B<C>
3688
3689 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3690
3691     if (...) {
3692          ...
3693     } else {
3694          ...
3695     }
3696
3697 instead of
3698
3699     if (...) {
3700          ...
3701     }
3702     else {
3703          ...
3704     }
3705
3706 The default is not to cuddle.
3707
3708 =item B<i>I<NUMBER>
3709
3710 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3711
3712 =item B<T>
3713
3714 Use tabs for each 8 columns of indent. The default is to use only spaces.
3715 For instance, if the style options are B<-si4T>, a line that's indented
3716 3 times will be preceded by one tab and four spaces; if the options were
3717 B<-si8T>, the same line would be preceded by three tabs.
3718
3719 =item B<v>I<STRING>B<.>
3720
3721 Print I<STRING> for the value of a constant that can't be determined
3722 because it was optimized away (mnemonic: this happens when a constant
3723 is used in B<v>oid context). The end of the string is marked by a period.
3724 The string should be a valid perl expression, generally a constant.
3725 Note that unless it's a number, it probably needs to be quoted, and on
3726 a command line quotes need to be protected from the shell. Some
3727 conventional values include 0, 1, 42, '', 'foo', and
3728 'Useless use of constant omitted' (which may need to be
3729 B<-sv"'Useless use of constant omitted'.">
3730 or something similar depending on your shell). The default is '???'.
3731 If you're using B::Deparse on a module or other file that's require'd,
3732 you shouldn't use a value that evaluates to false, since the customary
3733 true constant at the end of a module will be in void context when the
3734 file is compiled as a main program.
3735
3736 =back
3737
3738 =item B<-x>I<LEVEL>
3739
3740 Expand conventional syntax constructions into equivalent ones that expose
3741 their internal operation. I<LEVEL> should be a digit, with higher values
3742 meaning more expansion. As with B<-q>, this actually involves turning off
3743 special cases in B::Deparse's normal operations.
3744
3745 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3746 while loops with continue blocks; for instance
3747
3748     for ($i = 0; $i < 10; ++$i) {
3749         print $i;
3750     }
3751
3752 turns into
3753
3754     $i = 0;
3755     while ($i < 10) {
3756         print $i;
3757     } continue {
3758         ++$i
3759     }
3760
3761 Note that in a few cases this translation can't be perfectly carried back
3762 into the source code -- if the loop's initializer declares a my variable,
3763 for instance, it won't have the correct scope outside of the loop.
3764
3765 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3766 expressions using C<&&>, C<?:> and C<do {}>; for instance
3767
3768     print 'hi' if $nice;
3769     if ($nice) {
3770         print 'hi';
3771     }
3772     if ($nice) {
3773         print 'hi';
3774     } else {
3775         print 'bye';
3776     }
3777
3778 turns into
3779
3780     $nice and print 'hi';
3781     $nice and do { print 'hi' };
3782     $nice ? do { print 'hi' } : do { print 'bye' };
3783
3784 Long sequences of elsifs will turn into nested ternary operators, which
3785 B::Deparse doesn't know how to indent nicely.
3786
3787 =back
3788
3789 =head1 USING B::Deparse AS A MODULE
3790
3791 =head2 Synopsis
3792
3793     use B::Deparse;
3794     $deparse = B::Deparse->new("-p", "-sC");
3795     $body = $deparse->coderef2text(\&func);
3796     eval "sub func $body"; # the inverse operation
3797
3798 =head2 Description
3799
3800 B::Deparse can also be used on a sub-by-sub basis from other perl
3801 programs.
3802
3803 =head2 new
3804
3805     $deparse = B::Deparse->new(OPTIONS)
3806
3807 Create an object to store the state of a deparsing operation and any
3808 options. The options are the same as those that can be given on the
3809 command line (see L</OPTIONS>); options that are separated by commas
3810 after B<-MO=Deparse> should be given as separate strings. Some
3811 options, like B<-u>, don't make sense for a single subroutine, so
3812 don't pass them.
3813
3814 =head2 ambient_pragmas
3815
3816     $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3817
3818 The compilation of a subroutine can be affected by a few compiler
3819 directives, B<pragmas>. These are:
3820
3821 =over 4
3822
3823 =item *
3824
3825 use strict;
3826
3827 =item *
3828
3829 use warnings;
3830
3831 =item *
3832
3833 Assigning to the special variable $[
3834
3835 =item *
3836
3837 use integer;
3838
3839 =item *
3840
3841 use bytes;
3842
3843 =item *
3844
3845 use utf8;
3846
3847 =item *
3848
3849 use re;
3850
3851 =back
3852
3853 Ordinarily, if you use B::Deparse on a subroutine which has
3854 been compiled in the presence of one or more of these pragmas,
3855 the output will include statements to turn on the appropriate
3856 directives. So if you then compile the code returned by coderef2text,
3857 it will behave the same way as the subroutine which you deparsed.
3858
3859 However, you may know that you intend to use the results in a
3860 particular context, where some pragmas are already in scope. In
3861 this case, you use the B<ambient_pragmas> method to describe the
3862 assumptions you wish to make.
3863
3864 Not all of the options currently have any useful effect. See
3865 L</BUGS> for more details.
3866
3867 The parameters it accepts are:
3868
3869 =over 4
3870
3871 =item strict
3872
3873 Takes a string, possibly containing several values separated
3874 by whitespace. The special values "all" and "none" mean what you'd
3875 expect.
3876
3877     $deparse->ambient_pragmas(strict => 'subs refs');
3878
3879 =item $[
3880
3881 Takes a number, the value of the array base $[.
3882
3883 =item bytes
3884
3885 =item utf8
3886
3887 =item integer
3888
3889 If the value is true, then the appropriate pragma is assumed to
3890 be in the ambient scope, otherwise not.
3891
3892 =item re
3893
3894 Takes a string, possibly containing a whitespace-separated list of
3895 values. The values "all" and "none" are special. It's also permissible
3896 to pass an array reference here.
3897
3898     $deparser->ambient_pragmas(re => 'eval');
3899
3900
3901 =item warnings
3902
3903 Takes a string, possibly containing a whitespace-separated list of
3904 values. The values "all" and "none" are special, again. It's also
3905 permissible to pass an array reference here.
3906
3907     $deparser->ambient_pragmas(warnings => [qw[void io]]);
3908
3909 If one of the values is the string "FATAL", then all the warnings
3910 in that list will be considered fatal, just as with the B<warnings>
3911 pragma itself. Should you need to specify that some warnings are
3912 fatal, and others are merely enabled, you can pass the B<warnings>
3913 parameter twice:
3914
3915     $deparser->ambient_pragmas(
3916         warnings => 'all',
3917         warnings => [FATAL => qw/void io/],
3918     );
3919
3920 See L<perllexwarn> for more information about lexical warnings.
3921
3922 =item hint_bits
3923
3924 =item warning_bits
3925
3926 These two parameters are used to specify the ambient pragmas in
3927 the format used by the special variables $^H and ${^WARNING_BITS}.
3928
3929 They exist principally so that you can write code like:
3930
3931     { my ($hint_bits, $warning_bits);
3932     BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3933     $deparser->ambient_pragmas (
3934         hint_bits    => $hint_bits,
3935         warning_bits => $warning_bits,
3936         '$['         => 0 + $[
3937     ); }
3938
3939 which specifies that the ambient pragmas are exactly those which
3940 are in scope at the point of calling.
3941
3942 =back
3943
3944 =head2 coderef2text
3945
3946     $body = $deparse->coderef2text(\&func)
3947     $body = $deparse->coderef2text(sub ($$) { ... })
3948
3949 Return source code for the body of a subroutine (a block, optionally
3950 preceded by a prototype in parens), given a reference to the
3951 sub. Because a subroutine can have no names, or more than one name,
3952 this method doesn't return a complete subroutine definition -- if you
3953 want to eval the result, you should prepend "sub subname ", or "sub "
3954 for an anonymous function constructor. Unless the sub was defined in
3955 the main:: package, the code will include a package declaration.
3956
3957 =head1 BUGS
3958
3959 =over 4
3960
3961 =item *
3962
3963 The only pragmas to be completely supported are: C<use warnings>,
3964 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
3965 behaves like a pragma, is also supported.)
3966
3967 Excepting those listed above, we're currently unable to guarantee that
3968 B::Deparse will produce a pragma at the correct point in the program.
3969 Since the effects of pragmas are often lexically scoped, this can mean
3970 that the pragma holds sway over a different portion of the program
3971 than in the input file.
3972
3973 =item *
3974
3975 Lvalue method calls are not yet fully supported. (Ordinary lvalue
3976 subroutine calls ought to be okay though.)
3977
3978 =item *
3979
3980 If you have a regex which is anything other than a literal of some
3981 kind, B::Deparse will produce incorrect output.
3982 e.g. C<$foo =~ give_me_a_regex()> will come back as
3983 C<$foo =~ /give_me_a_regex()/>
3984
3985 =item *
3986
3987   m{ #foo
3988       bar }x
3989
3990 comes out as
3991
3992   m/#foo\n    bar/x)
3993
3994 which isn't right.
3995
3996 =item *
3997
3998 If a keyword is over-ridden, and your program explicitly calls
3999 the built-in version by using CORE::keyword, the output of B::Deparse
4000 will not reflect this.
4001
4002 =item *
4003
4004 C<sort foo (1, 2, 3)> comes out as C<sort (foo 1, 2, 3)>, which
4005 causes perl to issue a warning.
4006
4007 The obvious fix doesn't work, because these are different:
4008
4009     print (FOO 1, 2, 3), 4, 5, 6;
4010     print FOO (1, 2, 3), 4, 5, 6;
4011
4012 =item *
4013
4014 Constants (other than simple strings or numbers) don't work properly.
4015 Examples that fail include:
4016
4017     use constant E2BIG => ($!=7);
4018     use constant x=>\$x; print x
4019
4020 =item *
4021
4022 An input file that uses source filtering probably won't be deparsed into
4023 runnable code, because it will still include the B<use> declaration
4024 for the source filtering module, even though the code that is
4025 produced is already ordinary Perl which shouldn't be filtered again.
4026
4027 =item *
4028
4029 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4030
4031 =back
4032
4033 =head1 AUTHOR
4034
4035 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
4036 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
4037 contributions from Gisle Aas, James Duncan, Albert Dvornik, Robin
4038 Houston, Hugo van der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
4039
4040 =cut