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