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