ext/B/B/Deparse.pm

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