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