[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/i586-linux-thread-multi/B/ -> Deparse.pm (source)

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


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1