2 # Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant.
4 # This module is free software; you can redistribute and/or modify
5 # it under the same terms as Perl itself.
7 # This is based on the module of the same name by Malcolm Beattie,
8 # but essentially none of his code remains.
12 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
13 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
14 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPpPAD_STATE
15 OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
16 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
17 OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
18 OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
19 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
20 CVf_METHOD CVf_LOCKED CVf_LVALUE
21 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
22 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
23 ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE');
26 use vars qw/$AUTOLOAD/;
29 # Changes between 0.50 and 0.51:
30 # - fixed nulled leave with live enter in sort { }
31 # - fixed reference constants (\"str")
32 # - handle empty programs gracefully
33 # - handle infinte loops (for (;;) {}, while (1) {})
34 # - differentiate between `for my $x ...' and `my $x; for $x ...'
35 # - various minor cleanups
36 # - moved globals into an object
37 # - added `-u', like B::C
38 # - package declarations using cop_stash
39 # - subs, formats and code sorted by cop_seq
40 # Changes between 0.51 and 0.52:
41 # - added pp_threadsv (special variables under USE_5005THREADS)
42 # - added documentation
43 # Changes between 0.52 and 0.53:
44 # - many changes adding precedence contexts and associativity
45 # - added `-p' and `-s' output style options
46 # - various other minor fixes
47 # Changes between 0.53 and 0.54:
48 # - added support for new `for (1..100)' optimization,
50 # Changes between 0.54 and 0.55:
51 # - added support for new qr// construct
52 # - added support for new pp_regcreset OP
53 # Changes between 0.55 and 0.56:
54 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
55 # - fixed $# on non-lexicals broken in last big rewrite
56 # - added temporary fix for change in opcode of OP_STRINGIFY
57 # - fixed problem in 0.54's for() patch in `for (@ary)'
58 # - fixed precedence in conditional of ?:
59 # - tweaked list paren elimination in `my($x) = @_'
60 # - made continue-block detection trickier wrt. null ops
61 # - fixed various prototype problems in pp_entersub
62 # - added support for sub prototypes that never get GVs
63 # - added unquoting for special filehandle first arg in truncate
64 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
65 # - added semicolons at the ends of blocks
66 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
67 # Changes between 0.56 and 0.561:
68 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
69 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
70 # Changes between 0.561 and 0.57:
71 # - stylistic changes to symbolic constant stuff
72 # - handled scope in s///e replacement code
73 # - added unquote option for expanding "" into concats, etc.
74 # - split method and proto parts of pp_entersub into separate functions
75 # - various minor cleanups
77 # - added parens in \&foo (patch by Albert Dvornik)
78 # Changes between 0.57 and 0.58:
79 # - fixed `0' statements that weren't being printed
80 # - added methods for use from other programs
81 # (based on patches from James Duncan and Hugo van der Sanden)
82 # - added -si and -sT to control indenting (also based on a patch from Hugo)
83 # - added -sv to print something else instead of '???'
84 # - preliminary version of utf8 tr/// handling
86 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
87 # - added support for Hugo's new OP_SETSTATE (like nextstate)
88 # Changes between 0.58 and 0.59
89 # - added support for Chip's OP_METHOD_NAMED
90 # - added support for Ilya's OPpTARGET_MY optimization
91 # - elided arrows before `()' subscripts when possible
92 # Changes between 0.59 and 0.60
93 # - support for method attribues was added
94 # - some warnings fixed
95 # - separate recognition of constant subs
96 # - rewrote continue block handling, now recoginizing for loops
97 # - added more control of expanding control structures
98 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
100 # - support for pragmas and 'use'
101 # - support for the little-used $[ variable
102 # - support for __DATA__ sections
104 # - BEGIN, CHECK, INIT and END blocks
105 # - scoping of subroutine declarations fixed
106 # - compile-time output from the input program can be suppressed, so that the
107 # output is just the deparsed code. (a change to O.pm in fact)
108 # - our() declarations
109 # - *all* the known bugs are now listed in the BUGS section
110 # - comprehensive test mechanism (TEST -deparse)
111 # Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
114 # - support for command-line switches (-l, -0, etc.)
115 # Changes between 0.63 and 0.64
116 # - support for //, CHECK blocks, and assertions
117 # - improved handling of foreach loops and lexicals
118 # - option to use Data::Dumper for constants
120 # - discovered lots more bugs not yet fixed
124 # Changes between 0.72 and 0.73
125 # - support new switch constructs
128 # (See also BUGS section at the end of this file)
130 # - finish tr/// changes
131 # - add option for even more parens (generalize \&foo change)
132 # - left/right context
133 # - copy comments (look at real text with $^P?)
134 # - avoid semis in one-statement blocks
135 # - associativity of &&=, ||=, ?:
136 # - ',' => '=>' (auto-unquote?)
137 # - break long lines ("\r" as discretionary break?)
138 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
139 # - more style options: brace style, hex vs. octal, quotes, ...
140 # - print big ints as hex/octal instead of decimal (heuristic?)
141 # - handle `my $x if 0'?
142 # - version using op_next instead of op_first/sibling?
143 # - avoid string copies (pass arrays, one big join?)
146 # Current test.deparse failures
147 # comp/hints 6 - location of BEGIN blocks wrt. block openings
148 # run/switchI 1 - missing -I switches entirely
149 # perl -Ifoo -e 'print @INC'
150 # op/caller 2 - warning mask propagates backwards before warnings::register
151 # 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
152 # op/getpid 2 - can't assign to shared my() declaration (threads only)
153 # 'my $x : shared = 5'
154 # op/override 7 - parens on overriden require change v-string interpretation
155 # 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
156 # c.f. 'BEGIN { *f = sub {0} }; f 2'
157 # op/pat 774 - losing Unicode-ness of Latin1-only strings
158 # 'use charnames ":short"; $x="\N{latin:a with acute}"'
159 # op/recurse 12 - missing parens on recursive call makes it look like method
161 # op/subst 90 - inconsistent handling of utf8 under "use utf8"
162 # op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
163 # op/tiehandle compile - "use strict" deparsed in the wrong place
165 # ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
166 # ext/Data/Dumper/t/dumper compile
167 # ext/DB_file/several
169 # ext/Ernno/Errno warnings
170 # ext/IO/lib/IO/t/io_sel 23
171 # ext/PerlIO/t/encoding compile
172 # ext/POSIX/t/posix 6
173 # ext/Socket/Socket 8
174 # ext/Storable/t/croak compile
175 # lib/Attribute/Handlers/t/multi compile
176 # lib/bignum/ several
180 # lib/ExtUtils/t/bytes 4
181 # lib/File/DosGlob compile
182 # lib/Filter/Simple/t/data 1
183 # lib/Math/BigInt/t/constant 1
184 # lib/Net/t/config Deparse-warning
185 # lib/overload compile
186 # lib/Switch/ several
188 # lib/Test/Simple several
190 # lib/Tie/File/t/29_downcopy 5
193 # Object fields (were globals):
196 # (local($a), local($b)) and local($a, $b) have the same internal
197 # representation but the short form looks better. We notice we can
198 # use a large-scale local when checking the list, but need to prevent
199 # individual locals too. This hash holds the addresses of OPs that
200 # have already had their local-ness accounted for. The same thing
204 # CV for current sub (or main program) being deparsed
207 # Cached hash of lexical variables for curcv: keys are names,
208 # each value is an array of pairs, indicating the cop_seq of scopes
209 # in which a var of that name is valid.
212 # COP for statement being deparsed
215 # name of the current package for deparsed code
218 # array of [cop_seq, CV, is_format?] for subs and formats we still
222 # as above, but [name, prototype] for subs that never got a GV
224 # subs_done, forms_done:
225 # keys are addresses of GVs for subs and formats we've already
226 # deparsed (or at least put into subs_todo)
229 # keys are names of subs for which we've printed declarations.
230 # That means we can omit parentheses from the arguments.
233 # Keeps track of fully qualified names of all deparsed subs.
238 # cuddle: ` ' or `\n', depending on -sC
243 # A little explanation of how precedence contexts and associativity
246 # deparse() calls each per-op subroutine with an argument $cx (short
247 # for context, but not the same as the cx* in the perl core), which is
248 # a number describing the op's parents in terms of precedence, whether
249 # they're inside an expression or at statement level, etc. (see
250 # chart below). When ops with children call deparse on them, they pass
251 # along their precedence. Fractional values are used to implement
252 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
253 # parentheses hacks. The major disadvantage of this scheme is that
254 # it doesn't know about right sides and left sides, so say if you
255 # assign a listop to a variable, it can't tell it's allowed to leave
256 # the parens off the listop.
259 # 26 [TODO] inside interpolation context ("")
260 # 25 left terms and list operators (leftward)
264 # 21 right ! ~ \ and unary + and -
269 # 16 nonassoc named unary operators
270 # 15 nonassoc < > <= >= lt gt le ge
271 # 14 nonassoc == != <=> eq ne cmp
278 # 7 right = += -= *= etc.
280 # 5 nonassoc list operators (rightward)
284 # 1 statement modifiers
285 # 0.5 statements, but still print scopes as do { ... }
288 # Nonprinting characters with special meaning:
289 # \cS - steal parens (see maybe_parens_unop)
290 # \n - newline and indent
291 # \t - increase indent
292 # \b - decrease indent (`outdent')
293 # \f - flush left (no indent)
294 # \cK - kill following semicolon, if any
298 return class($op) eq "NULL";
303 my($cv, $is_form) = @_;
304 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
306 if ($cv->OUTSIDE_SEQ) {
307 $seq = $cv->OUTSIDE_SEQ;
308 } elsif (!null($cv->START) and is_state($cv->START)) {
309 $seq = $cv->START->cop_seq;
313 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
314 unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
315 $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
321 my $ent = shift @{$self->{'subs_todo'}};
324 my $name = $self->gv_name($gv);
326 return "format $name =\n"
327 . $self->deparse_format($ent->[1]). "\n";
329 $self->{'subs_declared'}{$name} = 1;
330 if ($name eq "BEGIN") {
331 my $use_dec = $self->begin_is_use($cv);
332 if (defined ($use_dec) and $self->{'expand'} < 5) {
333 return () if 0 == length($use_dec);
338 if ($self->{'linenums'}) {
339 my $line = $gv->LINE;
340 my $file = $gv->FILE;
341 $l = "\n\f#line $line \"$file\"\n";
344 if (class($cv->STASH) ne "SPECIAL") {
345 my $stash = $cv->STASH->NAME;
346 if ($stash ne $self->{'curstash'}) {
347 $p = "package $stash;\n";
348 $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
349 $self->{'curstash'} = $stash;
351 $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
353 return "${p}${l}sub $name " . $self->deparse_sub($cv);
357 # Return a "use" declaration for this BEGIN block, if appropriate
359 my ($self, $cv) = @_;
360 my $root = $cv->ROOT;
361 local @$self{qw'curcv curcvlex'} = ($cv);
363 #B::walkoptree($cv->ROOT, "debug");
364 my $lineseq = $root->first;
365 return if $lineseq->name ne "lineseq";
367 my $req_op = $lineseq->first->sibling;
368 return if $req_op->name ne "require";
371 if ($req_op->first->private & OPpCONST_BARE) {
372 # Actually it should always be a bareword
373 $module = $self->const_sv($req_op->first)->PV;
374 $module =~ s[/][::]g;
378 $module = $self->const($self->const_sv($req_op->first), 6);
382 my $version_op = $req_op->sibling;
383 return if class($version_op) eq "NULL";
384 if ($version_op->name eq "lineseq") {
385 # We have a version parameter; skip nextstate & pushmark
386 my $constop = $version_op->first->next->next;
388 return unless $self->const_sv($constop)->PV eq $module;
389 $constop = $constop->sibling;
390 $version = $self->const_sv($constop);
391 if (class($version) eq "IV") {
392 $version = $version->int_value;
393 } elsif (class($version) eq "NV") {
394 $version = $version->NV;
395 } elsif (class($version) ne "PVMG") {
396 # Includes PVIV and PVNV
397 $version = $version->PV;
399 # version specified as a v-string
400 $version = 'v'.join '.', map ord, split //, $version->PV;
402 $constop = $constop->sibling;
403 return if $constop->name ne "method_named";
404 return if $self->const_sv($constop)->PV ne "VERSION";
407 $lineseq = $version_op->sibling;
408 return if $lineseq->name ne "lineseq";
409 my $entersub = $lineseq->first->sibling;
410 if ($entersub->name eq "stub") {
411 return "use $module $version ();\n" if defined $version;
412 return "use $module ();\n";
414 return if $entersub->name ne "entersub";
416 # See if there are import arguments
419 my $svop = $entersub->first->sibling; # Skip over pushmark
420 return unless $self->const_sv($svop)->PV eq $module;
422 # Pull out the arguments
423 for ($svop=$svop->sibling; $svop->name ne "method_named";
424 $svop = $svop->sibling) {
425 $args .= ", " if length($args);
426 $args .= $self->deparse($svop, 6);
430 my $method_named = $svop;
431 return if $method_named->name ne "method_named";
432 my $method_name = $self->const_sv($method_named)->PV;
434 if ($method_name eq "unimport") {
438 # Certain pragmas are dealt with using hint bits,
439 # so we ignore them here
440 if ($module eq 'strict' || $module eq 'integer'
441 || $module eq 'bytes' || $module eq 'warnings'
442 || $module eq 'feature') {
446 if (defined $version && length $args) {
447 return "$use $module $version ($args);\n";
448 } elsif (defined $version) {
449 return "$use $module $version;\n";
450 } elsif (length $args) {
451 return "$use $module ($args);\n";
453 return "$use $module;\n";
458 my ($self, $pack) = @_;
460 if (!defined $pack) {
465 $pack =~ s/(::)?$/::/;
469 my %stash = svref_2object($stash)->ARRAY;
470 while (my ($key, $val) = each %stash) {
471 my $class = class($val);
472 if ($class eq "PV") {
473 # Just a prototype. As an ugly but fairly effective way
474 # to find out if it belongs here is to see if the AUTOLOAD
475 # (if any) for the stash was defined in one of our files.
476 my $A = $stash{"AUTOLOAD"};
477 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
478 && class($A->CV) eq "CV") {
480 next unless $AF eq $0 || exists $self->{'files'}{$AF};
482 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
483 } elsif ($class eq "IV") {
484 # Just a name. As above.
485 my $A = $stash{"AUTOLOAD"};
486 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
487 && class($A->CV) eq "CV") {
489 next unless $AF eq $0 || exists $self->{'files'}{$AF};
491 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
492 } elsif ($class eq "GV") {
493 if (class(my $cv = $val->CV) ne "SPECIAL") {
494 next if $self->{'subs_done'}{$$val}++;
495 next if $$val != ${$cv->GV}; # Ignore imposters
498 if (class(my $cv = $val->FORM) ne "SPECIAL") {
499 next if $self->{'forms_done'}{$$val}++;
500 next if $$val != ${$cv->GV}; # Ignore imposters
503 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
504 $self->stash_subs($pack . $key)
505 unless $pack eq '' && $key eq 'main::';
506 # avoid infinite recursion
516 foreach $ar (@{$self->{'protos_todo'}}) {
517 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
518 push @ret, "sub " . $ar->[0] . "$proto;\n";
520 delete $self->{'protos_todo'};
528 while (length($opt = substr($opts, 0, 1))) {
530 $self->{'cuddle'} = " ";
531 $opts = substr($opts, 1);
532 } elsif ($opt eq "i") {
533 $opts =~ s/^i(\d+)//;
534 $self->{'indent_size'} = $1;
535 } elsif ($opt eq "T") {
536 $self->{'use_tabs'} = 1;
537 $opts = substr($opts, 1);
538 } elsif ($opt eq "v") {
539 $opts =~ s/^v([^.]*)(.|$)//;
540 $self->{'ex_const'} = $1;
547 my $self = bless {}, $class;
548 $self->{'cuddle'} = "\n";
549 $self->{'curcop'} = undef;
550 $self->{'curstash'} = "main";
551 $self->{'ex_const'} = "'???'";
552 $self->{'expand'} = 0;
553 $self->{'files'} = {};
554 $self->{'indent_size'} = 4;
555 $self->{'linenums'} = 0;
556 $self->{'parens'} = 0;
557 $self->{'subs_todo'} = [];
558 $self->{'unquote'} = 0;
559 $self->{'use_dumper'} = 0;
560 $self->{'use_tabs'} = 0;
562 $self->{'ambient_arybase'} = 0;
563 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
564 $self->{'ambient_hints'} = 0;
565 $self->{'ambient_hinthash'} = undef;
568 while (my $arg = shift @_) {
570 $self->{'use_dumper'} = 1;
571 require Data::Dumper;
572 } elsif ($arg =~ /^-f(.*)/) {
573 $self->{'files'}{$1} = 1;
574 } elsif ($arg eq "-l") {
575 $self->{'linenums'} = 1;
576 } elsif ($arg eq "-p") {
577 $self->{'parens'} = 1;
578 } elsif ($arg eq "-P") {
579 $self->{'noproto'} = 1;
580 } elsif ($arg eq "-q") {
581 $self->{'unquote'} = 1;
582 } elsif (substr($arg, 0, 2) eq "-s") {
583 $self->style_opts(substr $arg, 2);
584 } elsif ($arg =~ /^-x(\d)$/) {
585 $self->{'expand'} = $1;
592 # Mask out the bits that L<warnings::register> uses
595 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
602 # Initialise the contextual information, either from
603 # defaults provided with the ambient_pragmas method,
604 # or from perl's own defaults otherwise.
608 $self->{'arybase'} = $self->{'ambient_arybase'};
609 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
610 ? $self->{'ambient_warnings'} & WARN_MASK
612 $self->{'hints'} = $self->{'ambient_hints'};
613 $self->{'hints'} &= 0xFF if $] < 5.009;
614 $self->{'hinthash'} = $self->{'ambient_hinthash'};
616 # also a convenient place to clear out subs_declared
617 delete $self->{'subs_declared'};
623 my $self = B::Deparse->new(@args);
624 # First deparse command-line args
625 if (defined $^I) { # deparse -i
626 print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
628 if ($^W) { # deparse -w
629 print qq(BEGIN { \$^W = $^W; }\n);
631 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
632 my $fs = perlstring($/) || 'undef';
633 my $bs = perlstring($O::savebackslash) || 'undef';
634 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
636 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
637 my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
638 ? B::unitcheck_av->ARRAY
640 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
641 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
642 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
643 for my $block (@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
644 $self->todo($block, 0);
647 local($SIG{"__DIE__"}) =
649 if ($self->{'curcop'}) {
650 my $cop = $self->{'curcop'};
651 my($line, $file) = ($cop->line, $cop->file);
652 print STDERR "While deparsing $file near line $line,\n";
655 $self->{'curcv'} = main_cv;
656 $self->{'curcvlex'} = undef;
657 print $self->print_protos;
658 @{$self->{'subs_todo'}} =
659 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
660 print $self->indent($self->deparse_root(main_root)), "\n"
661 unless null main_root;
663 while (scalar(@{$self->{'subs_todo'}})) {
664 push @text, $self->next_todo;
666 print $self->indent(join("", @text)), "\n" if @text;
668 # Print __DATA__ section, if necessary
670 my $laststash = defined $self->{'curcop'}
671 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
672 if (defined *{$laststash."::DATA"}{IO}) {
673 print "package $laststash;\n"
674 unless $laststash eq $self->{'curstash'};
676 print readline(*{$laststash."::DATA"});
684 croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
687 return $self->indent($self->deparse_sub(svref_2object($sub)));
690 sub ambient_pragmas {
692 my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
698 if ($name eq 'strict') {
701 if ($val eq 'none') {
702 $hint_bits &= ~strict::bits(qw/refs subs vars/);
708 @names = qw/refs subs vars/;
714 @names = split' ', $val;
716 $hint_bits |= strict::bits(@names);
719 elsif ($name eq '$[') {
723 elsif ($name eq 'integer'
725 || $name eq 'utf8') {
728 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
731 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
735 elsif ($name eq 're') {
737 if ($val eq 'none') {
738 $hint_bits &= ~re::bits(qw/taint eval/);
744 @names = qw/taint eval/;
750 @names = split' ',$val;
752 $hint_bits |= re::bits(@names);
755 elsif ($name eq 'warnings') {
756 if ($val eq 'none') {
757 $warning_bits = $warnings::NONE;
766 @names = split/\s+/, $val;
769 $warning_bits = $warnings::NONE if !defined ($warning_bits);
770 $warning_bits |= warnings::bits(@names);
773 elsif ($name eq 'warning_bits') {
774 $warning_bits = $val;
777 elsif ($name eq 'hint_bits') {
781 elsif ($name eq '%^H') {
786 croak "Unknown pragma type: $name";
790 croak "The ambient_pragmas method expects an even number of args";
793 $self->{'ambient_arybase'} = $arybase;
794 $self->{'ambient_warnings'} = $warning_bits;
795 $self->{'ambient_hints'} = $hint_bits;
796 $self->{'ambient_hinthash'} = $hinthash;
799 # This method is the inner loop, so try to keep it simple
804 Carp::confess("Null op in deparse") if !defined($op)
805 || class($op) eq "NULL";
806 my $meth = "pp_" . $op->name;
807 return $self->$meth($op, $cx);
813 my @lines = split(/\n/, $txt);
818 my $cmd = substr($line, 0, 1);
819 if ($cmd eq "\t" or $cmd eq "\b") {
820 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
821 if ($self->{'use_tabs'}) {
822 $leader = "\t" x ($level / 8) . " " x ($level % 8);
824 $leader = " " x $level;
826 $line = substr($line, 1);
828 if (substr($line, 0, 1) eq "\f") {
829 $line = substr($line, 1); # no indent
831 $line = $leader . $line;
835 return join("\n", @lines);
842 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
843 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
844 local $self->{'curcop'} = $self->{'curcop'};
845 if ($cv->FLAGS & SVf_POK) {
846 $proto = "(". $cv->PV . ") ";
848 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
850 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
851 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
852 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
855 local($self->{'curcv'}) = $cv;
856 local($self->{'curcvlex'});
857 local(@$self{qw'curstash warnings hints hinthash'})
858 = @$self{qw'curstash warnings hints hinthash'};
860 if (not null $cv->ROOT) {
861 my $lineseq = $cv->ROOT->first;
862 if ($lineseq->name eq "lineseq") {
864 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
867 $body = $self->lineseq(undef, @ops).";";
868 my $scope_en = $self->find_scope_en($lineseq);
869 if (defined $scope_en) {
870 my $subs = join"", $self->seq_subs($scope_en);
871 $body .= ";\n$subs" if length($subs);
875 $body = $self->deparse($cv->ROOT->first, 0);
879 my $sv = $cv->const_sv;
881 # uh-oh. inlinable sub... format it differently
882 return $proto . "{ " . $self->const($sv, 0) . " }\n";
883 } else { # XSUB? (or just a declaration)
887 return $proto ."{\n\t$body\n\b}" ."\n";
894 local($self->{'curcv'}) = $form;
895 local($self->{'curcvlex'});
896 local($self->{'in_format'}) = 1;
897 local(@$self{qw'curstash warnings hints hinthash'})
898 = @$self{qw'curstash warnings hints hinthash'};
899 my $op = $form->ROOT;
901 return "\f." if $op->first->name eq 'stub'
902 || $op->first->name eq 'nextstate';
903 $op = $op->first->first; # skip leavewrite, lineseq
904 while (not null $op) {
905 $op = $op->sibling; # skip nextstate
907 $kid = $op->first->sibling; # skip pushmark
908 push @text, "\f".$self->const_sv($kid)->PV;
909 $kid = $kid->sibling;
910 for (; not null $kid; $kid = $kid->sibling) {
911 push @exprs, $self->deparse($kid, 0);
913 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
916 return join("", @text) . "\f.";
921 return $op->name eq "leave" || $op->name eq "scope"
922 || $op->name eq "lineseq"
923 || ($op->name eq "null" && class($op) eq "UNOP"
924 && (is_scope($op->first) || $op->first->name eq "enter"));
928 my $name = $_[0]->name;
929 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
932 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
934 return (!null($op) and null($op->sibling)
935 and $op->name eq "null" and class($op) eq "UNOP"
936 and (($op->first->name =~ /^(and|or)$/
937 and $op->first->first->sibling->name eq "lineseq")
938 or ($op->first->name eq "lineseq"
939 and not null $op->first->first->sibling
940 and $op->first->first->sibling->name eq "unstack")
944 # Check if the op and its sibling are the initialization and the rest of a
945 # for (..;..;..) { ... } loop
948 # This OP might be almost anything, though it won't be a
949 # nextstate. (It's the initialization, so in the canonical case it
950 # will be an sassign.) The sibling is a lineseq whose first child
951 # is a nextstate and whose second is a leaveloop.
952 my $lseq = $op->sibling;
953 if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") {
954 if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
955 && (my $sib = $lseq->first->sibling)) {
956 return (!null($sib) && $sib->name eq "leaveloop");
964 return ($op->name eq "rv2sv" or
965 $op->name eq "padsv" or
966 $op->name eq "gv" or # only in array/hash constructs
967 $op->flags & OPf_KIDS && !null($op->first)
968 && $op->first->name eq "gvsv");
973 my($text, $cx, $prec) = @_;
974 if ($prec < $cx # unary ops nest just fine
975 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
976 or $self->{'parens'})
979 # In a unop, let parent reuse our parens; see maybe_parens_unop
980 $text = "\cS" . $text if $cx == 16;
987 # same as above, but get around the `if it looks like a function' rule
988 sub maybe_parens_unop {
990 my($name, $kid, $cx) = @_;
991 if ($cx > 16 or $self->{'parens'}) {
992 $kid = $self->deparse($kid, 1);
993 if ($name eq "umask" && $kid =~ /^\d+$/) {
994 $kid = sprintf("%#o", $kid);
996 return "$name($kid)";
998 $kid = $self->deparse($kid, 16);
999 if ($name eq "umask" && $kid =~ /^\d+$/) {
1000 $kid = sprintf("%#o", $kid);
1002 if (substr($kid, 0, 1) eq "\cS") {
1004 return $name . substr($kid, 1);
1005 } elsif (substr($kid, 0, 1) eq "(") {
1006 # avoid looks-like-a-function trap with extra parens
1007 # (`+' can lead to ambiguities)
1008 return "$name(" . $kid . ")";
1010 return "$name $kid";
1015 sub maybe_parens_func {
1017 my($func, $text, $cx, $prec) = @_;
1018 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
1019 return "$func($text)";
1021 return "$func $text";
1027 my($op, $cx, $text) = @_;
1028 my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
1029 if ($op->private & (OPpLVAL_INTRO|$our_intro)
1030 and not $self->{'avoid_local'}{$$op}) {
1031 my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
1032 if( $our_local eq 'our' ) {
1033 # XXX This assertion fails code with non-ASCII identifiers,
1034 # like ./ext/Encode/t/jperl.t
1035 die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
1036 $text =~ s/(\w+::)+//;
1038 if (want_scalar($op)) {
1039 return "$our_local $text";
1041 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
1050 my($op, $cx, $func, @args) = @_;
1051 if ($op->private & OPpTARGET_MY) {
1052 my $var = $self->padname($op->targ);
1053 my $val = $func->($self, $op, 7, @args);
1054 return $self->maybe_parens("$var = $val", $cx, 7);
1056 return $func->($self, $op, $cx, @args);
1063 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
1068 my($op, $cx, $text) = @_;
1069 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
1070 my $my = $op->private & OPpPAD_STATE ? "state" : "my";
1071 if (want_scalar($op)) {
1074 return $self->maybe_parens_func($my, $text, $cx, 16);
1081 # The following OPs don't have functions:
1083 # pp_padany -- does not exist after parsing
1086 if ($AUTOLOAD =~ s/^.*::pp_//) {
1087 warn "unexpected OP_".uc $AUTOLOAD;
1090 die "Undefined subroutine $AUTOLOAD called";
1094 sub DESTROY {} # Do not AUTOLOAD
1096 # $root should be the op which represents the root of whatever
1097 # we're sequencing here. If it's undefined, then we don't append
1098 # any subroutine declarations to the deparsed ops, otherwise we
1099 # append appropriate declarations.
1101 my($self, $root, @ops) = @_;
1104 my $out_cop = $self->{'curcop'};
1105 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1107 if (defined $root) {
1108 $limit_seq = $out_seq;
1110 $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1111 $limit_seq = $nseq if !defined($limit_seq)
1112 or defined($nseq) && $nseq < $limit_seq;
1114 $limit_seq = $self->{'limit_seq'}
1115 if defined($self->{'limit_seq'})
1116 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1117 local $self->{'limit_seq'} = $limit_seq;
1119 $self->walk_lineseq($root, \@ops,
1120 sub { push @exprs, $_[0]} );
1122 my $body = join(";\n", grep {length} @exprs);
1124 if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1125 $subs = join "\n", $self->seq_subs($limit_seq);
1127 return join(";\n", grep {length} $body, $subs);
1131 my($real_block, $self, $op, $cx) = @_;
1135 local(@$self{qw'curstash warnings hints hinthash'})
1136 = @$self{qw'curstash warnings hints hinthash'} if $real_block;
1138 $kid = $op->first->sibling; # skip enter
1139 if (is_miniwhile($kid)) {
1140 my $top = $kid->first;
1141 my $name = $top->name;
1142 if ($name eq "and") {
1144 } elsif ($name eq "or") {
1146 } else { # no conditional -> while 1 or until 0
1147 return $self->deparse($top->first, 1) . " while 1";
1149 my $cond = $top->first;
1150 my $body = $cond->sibling->first; # skip lineseq
1151 $cond = $self->deparse($cond, 1);
1152 $body = $self->deparse($body, 1);
1153 return "$body $name $cond";
1158 for (; !null($kid); $kid = $kid->sibling) {
1161 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
1162 return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
1164 my $lineseq = $self->lineseq($op, @kids);
1165 return (length ($lineseq) ? "$lineseq;" : "");
1169 sub pp_scope { scopeop(0, @_); }
1170 sub pp_lineseq { scopeop(0, @_); }
1171 sub pp_leave { scopeop(1, @_); }
1173 # This is a special case of scopeop and lineseq, for the case of the
1174 # main_root. The difference is that we print the output statements as
1175 # soon as we get them, for the sake of impatient users.
1179 local(@$self{qw'curstash warnings hints hinthash'})
1180 = @$self{qw'curstash warnings hints hinthash'};
1182 return if null $op->first; # Can happen, e.g., for Bytecode without -k
1183 for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
1186 $self->walk_lineseq($op, \@kids,
1187 sub { print $self->indent($_[0].';');
1188 print "\n" unless $_[1] == $#kids;
1193 my ($self, $op, $kids, $callback) = @_;
1195 for (my $i = 0; $i < @kids; $i++) {
1197 if (is_state $kids[$i]) {
1198 $expr = $self->deparse($kids[$i++], 0);
1200 $callback->($expr, $i);
1204 if (is_for_loop($kids[$i])) {
1205 $callback->($expr . $self->for_loop($kids[$i], 0), $i++);
1208 $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
1209 $expr =~ s/;\n?\z//;
1210 $callback->($expr, $i);
1214 # The BEGIN {} is used here because otherwise this code isn't executed
1215 # when you run B::Deparse on itself.
1217 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1218 "ENV", "ARGV", "ARGVOUT", "_"); }
1223 Carp::confess() unless ref($gv) eq "B::GV";
1224 my $stash = $gv->STASH->NAME;
1225 my $name = $gv->SAFENAME;
1226 if ($stash eq 'main' && $name =~ /^::/) {
1229 elsif (($stash eq 'main' && $globalnames{$name})
1230 or ($stash eq $self->{'curstash'} && !$globalnames{$name}
1231 && ($stash eq 'main' || $name !~ /::/))
1232 or $name =~ /^[^A-Za-z_:]/)
1236 $stash = $stash . "::";
1238 if ($name =~ /^(\^..|{)/) {
1239 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
1241 return $stash . $name;
1244 # Return the name to use for a stash variable.
1245 # If a lexical with the same name is in scope, it may need to be
1247 sub stash_variable {
1248 my ($self, $prefix, $name) = @_;
1250 return "$prefix$name" if $name =~ /::/;
1252 unless ($prefix eq '$' || $prefix eq '@' || #'
1253 $prefix eq '%' || $prefix eq '$#') {
1254 return "$prefix$name";
1257 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1258 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
1259 return "$prefix$name";
1263 my ($self, $name) = @_;
1264 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1266 return 0 if !defined($self->{'curcop'});
1267 my $seq = $self->{'curcop'}->cop_seq;
1268 return 0 if !exists $self->{'curcvlex'}{$name};
1269 for my $a (@{$self->{'curcvlex'}{$name}}) {
1270 my ($st, $en) = @$a;
1271 return 1 if $seq > $st && $seq <= $en;
1276 sub populate_curcvlex {
1278 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1279 my $padlist = $cv->PADLIST;
1280 # an undef CV still in lexical chain
1281 next if class($padlist) eq "SPECIAL";
1282 my @padlist = $padlist->ARRAY;
1283 my @ns = $padlist[0]->ARRAY;
1285 for (my $i=0; $i<@ns; ++$i) {
1286 next if class($ns[$i]) eq "SPECIAL";
1287 next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
1288 if (class($ns[$i]) eq "PV") {
1289 # Probably that pesky lexical @_
1292 my $name = $ns[$i]->PVX;
1293 my ($seq_st, $seq_en) =
1294 ($ns[$i]->FLAGS & SVf_FAKE)
1296 : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
1298 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1303 sub find_scope_st { ((find_scope(@_))[0]); }
1304 sub find_scope_en { ((find_scope(@_))[1]); }
1306 # Recurses down the tree, looking for pad variable introductions and COPs
1308 my ($self, $op, $scope_st, $scope_en) = @_;
1309 carp("Undefined op in find_scope") if !defined $op;
1310 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1313 while(my $op = shift @queue ) {
1314 for (my $o=$op->first; $$o; $o=$o->sibling) {
1315 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1316 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
1317 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
1318 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1319 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1320 return ($scope_st, $scope_en);
1322 elsif (is_state($o)) {
1323 my $c = $o->cop_seq;
1324 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1325 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1326 return ($scope_st, $scope_en);
1328 elsif ($o->flags & OPf_KIDS) {
1329 unshift (@queue, $o);
1334 return ($scope_st, $scope_en);
1337 # Returns a list of subs which should be inserted before the COP
1339 my ($self, $op, $out_seq) = @_;
1340 my $seq = $op->cop_seq;
1341 # If we have nephews, then our sequence number indicates
1342 # the cop_seq of the end of some sort of scope.
1343 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1344 and my $nseq = $self->find_scope_st($op->sibling) ) {
1347 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1348 return $self->seq_subs($seq);
1352 my ($self, $seq) = @_;
1354 #push @text, "# ($seq)\n";
1356 return "" if !defined $seq;
1357 while (scalar(@{$self->{'subs_todo'}})
1358 and $seq > $self->{'subs_todo'}[0][0]) {
1359 push @text, $self->next_todo;
1364 # Notice how subs and formats are inserted between statements here;
1365 # also $[ assignments and pragmas.
1369 $self->{'curcop'} = $op;
1371 push @text, $self->cop_subs($op);
1372 push @text, $op->label . ": " if $op->label;
1373 my $stash = $op->stashpv;
1374 if ($stash ne $self->{'curstash'}) {
1375 push @text, "package $stash;\n";
1376 $self->{'curstash'} = $stash;
1379 if ($self->{'arybase'} != $op->arybase) {
1380 push @text, '$[ = '. $op->arybase .";\n";
1381 $self->{'arybase'} = $op->arybase;
1384 my $warnings = $op->warnings;
1386 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1387 $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
1389 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1390 $warning_bits = $warnings::NONE;
1392 elsif ($warnings->isa("B::SPECIAL")) {
1393 $warning_bits = undef;
1396 $warning_bits = $warnings->PV & WARN_MASK;
1399 if (defined ($warning_bits) and
1400 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1401 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1402 $self->{'warnings'} = $warning_bits;
1405 if ($self->{'hints'} != $op->hints) {
1406 push @text, declare_hints($self->{'hints'}, $op->hints);
1407 $self->{'hints'} = $op->hints;
1410 # hack to check that the hint hash hasn't changed
1412 "@{[sort %{$self->{'hinthash'} || {}}]}"
1413 ne "@{[sort %{$op->hints_hash->HASH || {}}]}") {
1414 push @text, declare_hinthash($self->{'hinthash'}, $op->hints_hash->HASH, $self->{indent_size});
1415 $self->{'hinthash'} = $op->hints_hash->HASH;
1418 # This should go after of any branches that add statements, to
1419 # increase the chances that it refers to the same line it did in
1420 # the original program.
1421 if ($self->{'linenums'}) {
1422 push @text, "\f#line " . $op->line .
1423 ' "' . $op->file, qq'"\n';
1426 return join("", @text);
1429 sub declare_warnings {
1430 my ($from, $to) = @_;
1431 if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
1432 return "use warnings;\n";
1434 elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
1435 return "no warnings;\n";
1437 return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
1441 my ($from, $to) = @_;
1442 my $use = $to & ~$from;
1443 my $no = $from & ~$to;
1445 for my $pragma (hint_pragmas($use)) {
1446 $decls .= "use $pragma;\n";
1448 for my $pragma (hint_pragmas($no)) {
1449 $decls .= "no $pragma;\n";
1454 # Internal implementation hints that the core sets automatically, so don't need
1455 # (or want) to be passed back to the user
1456 my %ignored_hints = (
1462 sub declare_hinthash {
1463 my ($from, $to, $indent) = @_;
1465 for my $key (keys %$to) {
1466 next if $ignored_hints{$key};
1467 if (!defined $from->{$key} or $from->{$key} ne $to->{$key}) {
1468 push @decls, qq(\$^H{'$key'} = q($to->{$key}););
1471 for my $key (keys %$from) {
1472 next if $ignored_hints{$key};
1473 if (!exists $to->{$key}) {
1474 push @decls, qq(delete \$^H{'$key'};);
1477 @decls or return '';
1478 return join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n";
1484 push @pragmas, "integer" if $bits & 0x1;
1485 push @pragmas, "strict 'refs'" if $bits & 0x2;
1486 push @pragmas, "bytes" if $bits & 0x8;
1490 sub pp_dbstate { pp_nextstate(@_) }
1491 sub pp_setstate { pp_nextstate(@_) }
1493 sub pp_unstack { return "" } # see also leaveloop
1497 my($op, $cx, $name) = @_;
1503 my($op, $cx, $name) = @_;
1511 sub pp_wantarray { baseop(@_, "wantarray") }
1512 sub pp_fork { baseop(@_, "fork") }
1513 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1514 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1515 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1516 sub pp_tms { baseop(@_, "times") }
1517 sub pp_ghostent { baseop(@_, "gethostent") }
1518 sub pp_gnetent { baseop(@_, "getnetent") }
1519 sub pp_gprotoent { baseop(@_, "getprotoent") }
1520 sub pp_gservent { baseop(@_, "getservent") }
1521 sub pp_ehostent { baseop(@_, "endhostent") }
1522 sub pp_enetent { baseop(@_, "endnetent") }
1523 sub pp_eprotoent { baseop(@_, "endprotoent") }
1524 sub pp_eservent { baseop(@_, "endservent") }
1525 sub pp_gpwent { baseop(@_, "getpwent") }
1526 sub pp_spwent { baseop(@_, "setpwent") }
1527 sub pp_epwent { baseop(@_, "endpwent") }
1528 sub pp_ggrent { baseop(@_, "getgrent") }
1529 sub pp_sgrent { baseop(@_, "setgrent") }
1530 sub pp_egrent { baseop(@_, "endgrent") }
1531 sub pp_getlogin { baseop(@_, "getlogin") }
1533 sub POSTFIX () { 1 }
1535 # I couldn't think of a good short name, but this is the category of
1536 # symbolic unary operators with interesting precedence
1540 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1541 my $kid = $op->first;
1542 $kid = $self->deparse($kid, $prec);
1543 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1547 sub pp_preinc { pfixop(@_, "++", 23) }
1548 sub pp_predec { pfixop(@_, "--", 23) }
1549 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1550 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1551 sub pp_i_preinc { pfixop(@_, "++", 23) }
1552 sub pp_i_predec { pfixop(@_, "--", 23) }
1553 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1554 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1555 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1557 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1561 if ($op->first->name =~ /^(i_)?negate$/) {
1563 $self->pfixop($op, $cx, "-", 21.5);
1565 $self->pfixop($op, $cx, "-", 21);
1568 sub pp_i_negate { pp_negate(@_) }
1574 $self->pfixop($op, $cx, "not ", 4);
1576 $self->pfixop($op, $cx, "!", 21);
1582 my($op, $cx, $name) = @_;
1584 if ($op->flags & OPf_KIDS) {
1586 if (defined prototype("CORE::$name")
1587 && prototype("CORE::$name") =~ /^;?\*/
1588 && $kid->name eq "rv2gv") {
1592 return $self->maybe_parens_unop($name, $kid, $cx);
1594 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1598 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1599 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1600 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1601 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1602 sub pp_defined { unop(@_, "defined") }
1603 sub pp_undef { unop(@_, "undef") }
1604 sub pp_study { unop(@_, "study") }
1605 sub pp_ref { unop(@_, "ref") }
1606 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1608 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1609 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1610 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1611 sub pp_srand { unop(@_, "srand") }
1612 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1613 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1614 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1615 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1616 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1617 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1618 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1620 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1621 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1622 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1624 sub pp_each { unop(@_, "each") }
1625 sub pp_values { unop(@_, "values") }
1626 sub pp_keys { unop(@_, "keys") }
1627 sub pp_aeach { unop(@_, "each") }
1628 sub pp_avalues { unop(@_, "values") }
1629 sub pp_akeys { unop(@_, "keys") }
1630 sub pp_pop { unop(@_, "pop") }
1631 sub pp_shift { unop(@_, "shift") }
1633 sub pp_caller { unop(@_, "caller") }
1634 sub pp_reset { unop(@_, "reset") }
1635 sub pp_exit { unop(@_, "exit") }
1636 sub pp_prototype { unop(@_, "prototype") }
1638 sub pp_close { unop(@_, "close") }
1639 sub pp_fileno { unop(@_, "fileno") }
1640 sub pp_umask { unop(@_, "umask") }
1641 sub pp_untie { unop(@_, "untie") }
1642 sub pp_tied { unop(@_, "tied") }
1643 sub pp_dbmclose { unop(@_, "dbmclose") }
1644 sub pp_getc { unop(@_, "getc") }
1645 sub pp_eof { unop(@_, "eof") }
1646 sub pp_tell { unop(@_, "tell") }
1647 sub pp_getsockname { unop(@_, "getsockname") }
1648 sub pp_getpeername { unop(@_, "getpeername") }
1650 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1651 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1652 sub pp_readlink { unop(@_, "readlink") }
1653 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1654 sub pp_readdir { unop(@_, "readdir") }
1655 sub pp_telldir { unop(@_, "telldir") }
1656 sub pp_rewinddir { unop(@_, "rewinddir") }
1657 sub pp_closedir { unop(@_, "closedir") }
1658 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1659 sub pp_localtime { unop(@_, "localtime") }
1660 sub pp_gmtime { unop(@_, "gmtime") }
1661 sub pp_alarm { unop(@_, "alarm") }
1662 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1664 sub pp_dofile { unop(@_, "do") }
1665 sub pp_entereval { unop(@_, "eval") }
1667 sub pp_ghbyname { unop(@_, "gethostbyname") }
1668 sub pp_gnbyname { unop(@_, "getnetbyname") }
1669 sub pp_gpbyname { unop(@_, "getprotobyname") }
1670 sub pp_shostent { unop(@_, "sethostent") }
1671 sub pp_snetent { unop(@_, "setnetent") }
1672 sub pp_sprotoent { unop(@_, "setprotoent") }
1673 sub pp_sservent { unop(@_, "setservent") }
1674 sub pp_gpwnam { unop(@_, "getpwnam") }
1675 sub pp_gpwuid { unop(@_, "getpwuid") }
1676 sub pp_ggrnam { unop(@_, "getgrnam") }
1677 sub pp_ggrgid { unop(@_, "getgrgid") }
1679 sub pp_lock { unop(@_, "lock") }
1681 sub pp_continue { unop(@_, "continue"); }
1683 my ($self, $op) = @_;
1684 return "" if $op->flags & OPf_SPECIAL;
1690 my($op, $cx, $givwhen) = @_;
1692 my $enterop = $op->first;
1694 if ($enterop->flags & OPf_SPECIAL) {
1696 $block = $self->deparse($enterop->first, 0);
1699 my $cond = $enterop->first;
1700 my $cond_str = $self->deparse($cond, 1);
1701 $head = "$givwhen ($cond_str)";
1702 $block = $self->deparse($cond->sibling, 0);
1710 sub pp_leavegiven { givwhen(@_, "given"); }
1711 sub pp_leavewhen { givwhen(@_, "when"); }
1717 if ($op->private & OPpEXISTS_SUB) {
1718 # Checking for the existence of a subroutine
1719 return $self->maybe_parens_func("exists",
1720 $self->pp_rv2cv($op->first, 16), $cx, 16);
1722 if ($op->flags & OPf_SPECIAL) {
1723 # Array element, not hash element
1724 return $self->maybe_parens_func("exists",
1725 $self->pp_aelem($op->first, 16), $cx, 16);
1727 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1735 if ($op->private & OPpSLICE) {
1736 if ($op->flags & OPf_SPECIAL) {
1737 # Deleting from an array, not a hash
1738 return $self->maybe_parens_func("delete",
1739 $self->pp_aslice($op->first, 16),
1742 return $self->maybe_parens_func("delete",
1743 $self->pp_hslice($op->first, 16),
1746 if ($op->flags & OPf_SPECIAL) {
1747 # Deleting from an array, not a hash
1748 return $self->maybe_parens_func("delete",
1749 $self->pp_aelem($op->first, 16),
1752 return $self->maybe_parens_func("delete",
1753 $self->pp_helem($op->first, 16),
1761 my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
1762 if (class($op) eq "UNOP" and $op->first->name eq "const"
1763 and $op->first->private & OPpCONST_BARE)
1765 my $name = $self->const_sv($op->first)->PV;
1768 return "$opname $name";
1770 $self->unop($op, $cx, $opname);
1777 my $kid = $op->first;
1778 if (not null $kid->sibling) {
1779 # XXX Was a here-doc
1780 return $self->dquote($op);
1782 $self->unop(@_, "scalar");
1789 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
1792 sub anon_hash_or_list {
1796 my($pre, $post) = @{{"anonlist" => ["[","]"],
1797 "anonhash" => ["{","}"]}->{$op->name}};
1799 $op = $op->first->sibling; # skip pushmark
1800 for (; !null($op); $op = $op->sibling) {
1801 $expr = $self->deparse($op, 6);
1804 if ($pre eq "{" and $cx < 1) {
1805 # Disambiguate that it's not a block
1808 return $pre . join(", ", @exprs) . $post;
1814 if ($op->flags & OPf_SPECIAL) {
1815 return $self->anon_hash_or_list($op, $cx);
1817 warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
1821 *pp_anonhash = \&pp_anonlist;
1826 my $kid = $op->first;
1827 if ($kid->name eq "null") {
1829 if (!null($kid->sibling) and
1830 $kid->sibling->name eq "anoncode") {
1831 return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) });
1832 } elsif ($kid->name eq "pushmark") {
1833 my $sib_name = $kid->sibling->name;
1834 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1835 and not $kid->sibling->flags & OPf_REF)
1837 # The @a in \(@a) isn't in ref context, but only when the
1839 return "\\(" . $self->pp_list($op->first) . ")";
1840 } elsif ($sib_name eq 'entersub') {
1841 my $text = $self->deparse($kid->sibling, 1);
1842 # Always show parens for \(&func()), but only with -p otherwise
1843 $text = "($text)" if $self->{'parens'}
1844 or $kid->sibling->private & OPpENTERSUB_AMPER;
1849 $self->pfixop($op, $cx, "\\", 20);
1853 my ($self, $info) = @_;
1854 my $text = $self->deparse_sub($info->{code});
1855 return "sub " . $text;
1858 sub pp_srefgen { pp_refgen(@_) }
1863 my $kid = $op->first;
1864 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1865 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1866 return $self->unop($op, $cx, "readline");
1872 return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
1875 # Unary operators that can occur as pseudo-listops inside double quotes
1878 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1880 if ($op->flags & OPf_KIDS) {
1882 # If there's more than one kid, the first is an ex-pushmark.
1883 $kid = $kid->sibling if not null $kid->sibling;
1884 return $self->maybe_parens_unop($name, $kid, $cx);
1886 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1890 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1891 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1892 sub pp_uc { dq_unop(@_, "uc") }
1893 sub pp_lc { dq_unop(@_, "lc") }
1894 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1898 my ($op, $cx, $name) = @_;
1899 if (class($op) eq "PVOP") {
1900 return "$name " . $op->pv;
1901 } elsif (class($op) eq "OP") {
1903 } elsif (class($op) eq "UNOP") {
1904 # Note -- loop exits are actually exempt from the
1905 # looks-like-a-func rule, but a few extra parens won't hurt
1906 return $self->maybe_parens_unop($name, $op->first, $cx);
1910 sub pp_last { loopex(@_, "last") }
1911 sub pp_next { loopex(@_, "next") }
1912 sub pp_redo { loopex(@_, "redo") }
1913 sub pp_goto { loopex(@_, "goto") }
1914 sub pp_dump { loopex(@_, "dump") }
1918 my($op, $cx, $name) = @_;
1919 if (class($op) eq "UNOP") {
1920 # Genuine `-X' filetests are exempt from the LLAFR, but not
1921 # l?stat(); for the sake of clarity, give'em all parens
1922 return $self->maybe_parens_unop($name, $op->first, $cx);
1923 } elsif (class($op) =~ /^(SV|PAD)OP$/) {
1924 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1925 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1930 sub pp_lstat { ftst(@_, "lstat") }
1931 sub pp_stat { ftst(@_, "stat") }
1932 sub pp_ftrread { ftst(@_, "-R") }
1933 sub pp_ftrwrite { ftst(@_, "-W") }
1934 sub pp_ftrexec { ftst(@_, "-X") }
1935 sub pp_fteread { ftst(@_, "-r") }
1936 sub pp_ftewrite { ftst(@_, "-w") }
1937 sub pp_fteexec { ftst(@_, "-x") }
1938 sub pp_ftis { ftst(@_, "-e") }
1939 sub pp_fteowned { ftst(@_, "-O") }
1940 sub pp_ftrowned { ftst(@_, "-o") }
1941 sub pp_ftzero { ftst(@_, "-z") }
1942 sub pp_ftsize { ftst(@_, "-s") }
1943 sub pp_ftmtime { ftst(@_, "-M") }
1944 sub pp_ftatime { ftst(@_, "-A") }
1945 sub pp_ftctime { ftst(@_, "-C") }
1946 sub pp_ftsock { ftst(@_, "-S") }
1947 sub pp_ftchr { ftst(@_, "-c") }
1948 sub pp_ftblk { ftst(@_, "-b") }
1949 sub pp_ftfile { ftst(@_, "-f") }
1950 sub pp_ftdir { ftst(@_, "-d") }
1951 sub pp_ftpipe { ftst(@_, "-p") }
1952 sub pp_ftlink { ftst(@_, "-l") }
1953 sub pp_ftsuid { ftst(@_, "-u") }
1954 sub pp_ftsgid { ftst(@_, "-g") }
1955 sub pp_ftsvtx { ftst(@_, "-k") }
1956 sub pp_fttty { ftst(@_, "-t") }
1957 sub pp_fttext { ftst(@_, "-T") }
1958 sub pp_ftbinary { ftst(@_, "-B") }
1960 sub SWAP_CHILDREN () { 1 }
1961 sub ASSIGN () { 2 } # has OP= variant
1962 sub LIST_CONTEXT () { 4 } # Assignment is in list context
1968 my $name = $op->name;
1969 if ($name eq "concat" and $op->first->name eq "concat") {
1970 # avoid spurious `=' -- see comment in pp_concat
1973 if ($name eq "null" and class($op) eq "UNOP"
1974 and $op->first->name =~ /^(and|x?or)$/
1975 and null $op->first->sibling)
1977 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1978 # with a null that's used as the common end point of the two
1979 # flows of control. For precedence purposes, ignore it.
1980 # (COND_EXPRs have these too, but we don't bother with
1981 # their associativity).
1982 return assoc_class($op->first);
1984 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1987 # Left associative operators, like `+', for which
1988 # $a + $b + $c is equivalent to ($a + $b) + $c
1991 %left = ('multiply' => 19, 'i_multiply' => 19,
1992 'divide' => 19, 'i_divide' => 19,
1993 'modulo' => 19, 'i_modulo' => 19,
1995 'add' => 18, 'i_add' => 18,
1996 'subtract' => 18, 'i_subtract' => 18,
1998 'left_shift' => 17, 'right_shift' => 17,
2000 'bit_or' => 12, 'bit_xor' => 12,
2002 'or' => 2, 'xor' => 2,
2006 sub deparse_binop_left {
2008 my($op, $left, $prec) = @_;
2009 if ($left{assoc_class($op)} && $left{assoc_class($left)}
2010 and $left{assoc_class($op)} == $left{assoc_class($left)})
2012 return $self->deparse($left, $prec - .00001);
2014 return $self->deparse($left, $prec);
2018 # Right associative operators, like `=', for which
2019 # $a = $b = $c is equivalent to $a = ($b = $c)
2022 %right = ('pow' => 22,
2023 'sassign=' => 7, 'aassign=' => 7,
2024 'multiply=' => 7, 'i_multiply=' => 7,
2025 'divide=' => 7, 'i_divide=' => 7,
2026 'modulo=' => 7, 'i_modulo=' => 7,
2028 'add=' => 7, 'i_add=' => 7,
2029 'subtract=' => 7, 'i_subtract=' => 7,
2031 'left_shift=' => 7, 'right_shift=' => 7,
2033 'bit_or=' => 7, 'bit_xor=' => 7,
2039 sub deparse_binop_right {
2041 my($op, $right, $prec) = @_;
2042 if ($right{assoc_class($op)} && $right{assoc_class($right)}
2043 and $right{assoc_class($op)} == $right{assoc_class($right)})
2045 return $self->deparse($right, $prec - .00001);
2047 return $self->deparse($right, $prec);
2053 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
2054 my $left = $op->first;
2055 my $right = $op->last;
2057 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
2061 if ($flags & SWAP_CHILDREN) {
2062 ($left, $right) = ($right, $left);
2064 $left = $self->deparse_binop_left($op, $left, $prec);
2065 $left = "($left)" if $flags & LIST_CONTEXT
2066 && $left !~ /^(my|our|local|)[\@\(]/;
2067 $right = $self->deparse_binop_right($op, $right, $prec);
2068 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
2071 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2072 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2073 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
2074 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2075 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2076 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2077 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2078 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
2079 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2080 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2081 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
2083 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
2084 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
2085 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
2086 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
2087 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
2089 sub pp_eq { binop(@_, "==", 14) }
2090 sub pp_ne { binop(@_, "!=", 14) }
2091 sub pp_lt { binop(@_, "<", 15) }
2092 sub pp_gt { binop(@_, ">", 15) }
2093 sub pp_ge { binop(@_, ">=", 15) }
2094 sub pp_le { binop(@_, "<=", 15) }
2095 sub pp_ncmp { binop(@_, "<=>", 14) }
2096 sub pp_i_eq { binop(@_, "==", 14) }
2097 sub pp_i_ne { binop(@_, "!=", 14) }
2098 sub pp_i_lt { binop(@_, "<", 15) }
2099 sub pp_i_gt { binop(@_, ">", 15) }
2100 sub pp_i_ge { binop(@_, ">=", 15) }
2101 sub pp_i_le { binop(@_, "<=", 15) }
2102 sub pp_i_ncmp { binop(@_, "<=>", 14) }
2104 sub pp_seq { binop(@_, "eq", 14) }
2105 sub pp_sne { binop(@_, "ne", 14) }
2106 sub pp_slt { binop(@_, "lt", 15) }
2107 sub pp_sgt { binop(@_, "gt", 15) }
2108 sub pp_sge { binop(@_, "ge", 15) }
2109 sub pp_sle { binop(@_, "le", 15) }
2110 sub pp_scmp { binop(@_, "cmp", 14) }
2112 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
2113 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
2116 my ($self, $op, $cx) = @_;
2117 if ($op->flags & OPf_SPECIAL) {
2118 return $self->deparse($op->last, $cx);
2121 binop(@_, "~~", 14);
2125 # `.' is special because concats-of-concats are optimized to save copying
2126 # by making all but the first concat stacked. The effect is as if the
2127 # programmer had written `($a . $b) .= $c', except legal.
2128 sub pp_concat { maybe_targmy(@_, \&real_concat) }
2132 my $left = $op->first;
2133 my $right = $op->last;
2136 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
2140 $left = $self->deparse_binop_left($op, $left, $prec);
2141 $right = $self->deparse_binop_right($op, $right, $prec);
2142 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
2145 # `x' is weird when the left arg is a list
2149 my $left = $op->first;
2150 my $right = $op->last;
2153 if ($op->flags & OPf_STACKED) {
2157 if (null($right)) { # list repeat; count is inside left-side ex-list
2158 my $kid = $left->first->sibling; # skip pushmark
2160 for (; !null($kid->sibling); $kid = $kid->sibling) {
2161 push @exprs, $self->deparse($kid, 6);
2164 $left = "(" . join(", ", @exprs). ")";
2166 $left = $self->deparse_binop_left($op, $left, $prec);
2168 $right = $self->deparse_binop_right($op, $right, $prec);
2169 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
2174 my ($op, $cx, $type) = @_;
2175 my $left = $op->first;
2176 my $right = $left->sibling;
2177 $left = $self->deparse($left, 9);
2178 $right = $self->deparse($right, 9);
2179 return $self->maybe_parens("$left $type $right", $cx, 9);
2185 my $flip = $op->first;
2186 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
2187 return $self->range($flip->first, $cx, $type);
2190 # one-line while/until is handled in pp_leave
2194 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
2195 my $left = $op->first;
2196 my $right = $op->first->sibling;
2197 if ($cx < 1 and is_scope($right) and $blockname
2198 and $self->{'expand'} < 7)
2200 $left = $self->deparse($left, 1);
2201 $right = $self->deparse($right, 0);
2202 return "$blockname ($left) {\n\t$right\n\b}\cK";
2203 } elsif ($cx < 1 and $blockname and not $self->{'parens'}
2204 and $self->{'expand'} < 7) { # $b if $a
2205 $right = $self->deparse($right, 1);
2206 $left = $self->deparse($left, 1);
2207 return "$right $blockname $left";
2208 } elsif ($cx > $lowprec and $highop) { # $a && $b
2209 $left = $self->deparse_binop_left($op, $left, $highprec);
2210 $right = $self->deparse_binop_right($op, $right, $highprec);
2211 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
2212 } else { # $a and $b
2213 $left = $self->deparse_binop_left($op, $left, $lowprec);
2214 $right = $self->deparse_binop_right($op, $right, $lowprec);
2215 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
2219 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
2220 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
2221 sub pp_dor { logop(@_, "err", 2, "//", 10, "") }
2223 # xor is syntactically a logop, but it's really a binop (contrary to
2224 # old versions of opcode.pl). Syntax is what matters here.
2225 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
2229 my ($op, $cx, $opname) = @_;
2230 my $left = $op->first;
2231 my $right = $op->first->sibling->first; # skip sassign
2232 $left = $self->deparse($left, 7);
2233 $right = $self->deparse($right, 7);
2234 return $self->maybe_parens("$left $opname $right", $cx, 7);
2237 sub pp_andassign { logassignop(@_, "&&=") }
2238 sub pp_orassign { logassignop(@_, "||=") }
2239 sub pp_dorassign { logassignop(@_, "//=") }
2243 my($op, $cx, $name) = @_;
2245 my $parens = ($cx >= 5) || $self->{'parens'};
2246 my $kid = $op->first->sibling;
2247 return $name if null $kid;
2249 $name = "socketpair" if $name eq "sockpair";
2250 my $proto = prototype("CORE::$name");
2252 && $proto =~ /^;?\*/
2253 && $kid->name eq "rv2gv") {
2254 $first = $self->deparse($kid->first, 6);
2257 $first = $self->deparse($kid, 6);
2259 if ($name eq "chmod" && $first =~ /^\d+$/) {
2260 $first = sprintf("%#o", $first);
2262 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
2263 push @exprs, $first;
2264 $kid = $kid->sibling;
2265 if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
2266 push @exprs, $self->deparse($kid->first, 6);
2267 $kid = $kid->sibling;
2269 for (; !null($kid); $kid = $kid->sibling) {
2270 push @exprs, $self->deparse($kid, 6);
2273 return "$name(" . join(", ", @exprs) . ")";
2275 return "$name " . join(", ", @exprs);
2279 sub pp_bless { listop(@_, "bless") }
2280 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2281 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
2282 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2283 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2284 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2285 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2286 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2287 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2288 sub pp_unpack { listop(@_, "unpack") }
2289 sub pp_pack { listop(@_, "pack") }
2290 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2291 sub pp_splice { listop(@_, "splice") }
2292 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2293 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2294 sub pp_reverse { listop(@_, "reverse") }
2295 sub pp_warn { listop(@_, "warn") }
2296 sub pp_die { listop(@_, "die") }
2297 # Actually, return is exempt from the LLAFR (see examples in this very
2298 # module!), but for consistency's sake, ignore that fact
2299 sub pp_return { listop(@_, "return") }
2300 sub pp_open { listop(@_, "open") }
2301 sub pp_pipe_op { listop(@_, "pipe") }
2302 sub pp_tie { listop(@_, "tie") }
2303 sub pp_binmode { listop(@_, "binmode") }
2304 sub pp_dbmopen { listop(@_, "dbmopen") }
2305 sub pp_sselect { listop(@_, "select") }
2306 sub pp_select { listop(@_, "select") }
2307 sub pp_read { listop(@_, "read") }
2308 sub pp_sysopen { listop(@_, "sysopen") }
2309 sub pp_sysseek { listop(@_, "sysseek") }
2310 sub pp_sysread { listop(@_, "sysread") }
2311 sub pp_syswrite { listop(@_, "syswrite") }
2312 sub pp_send { listop(@_, "send") }
2313 sub pp_recv { listop(@_, "recv") }
2314 sub pp_seek { listop(@_, "seek") }
2315 sub pp_fcntl { listop(@_, "fcntl") }
2316 sub pp_ioctl { listop(@_, "ioctl") }
2317 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2318 sub pp_socket { listop(@_, "socket") }
2319 sub pp_sockpair { listop(@_, "sockpair") }
2320 sub pp_bind { listop(@_, "bind") }
2321 sub pp_connect { listop(@_, "connect") }
2322 sub pp_listen { listop(@_, "listen") }
2323 sub pp_accept { listop(@_, "accept") }
2324 sub pp_shutdown { listop(@_, "shutdown") }
2325 sub pp_gsockopt { listop(@_, "getsockopt") }
2326 sub pp_ssockopt { listop(@_, "setsockopt") }
2327 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2328 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2329 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2330 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2331 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2332 sub pp_link { maybe_targmy(@_, \&listop, "link") }
2333 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2334 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2335 sub pp_open_dir { listop(@_, "opendir") }
2336 sub pp_seekdir { listop(@_, "seekdir") }
2337 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2338 sub pp_system { maybe_targmy(@_, \&listop, "system") }
2339 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2340 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2341 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2342 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2343 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2344 sub pp_shmget { listop(@_, "shmget") }
2345 sub pp_shmctl { listop(@_, "shmctl") }
2346 sub pp_shmread { listop(@_, "shmread") }
2347 sub pp_shmwrite { listop(@_, "shmwrite") }
2348 sub pp_msgget { listop(@_, "msgget") }
2349 sub pp_msgctl { listop(@_, "msgctl") }
2350 sub pp_msgsnd { listop(@_, "msgsnd") }
2351 sub pp_msgrcv { listop(@_, "msgrcv") }
2352 sub pp_semget { listop(@_, "semget") }
2353 sub pp_semctl { listop(@_, "semctl") }
2354 sub pp_semop { listop(@_, "semop") }
2355 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2356 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2357 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2358 sub pp_gsbyname { listop(@_, "getservbyname") }
2359 sub pp_gsbyport { listop(@_, "getservbyport") }
2360 sub pp_syscall { listop(@_, "syscall") }
2365 my $text = $self->dq($op->first->sibling); # skip pushmark
2366 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
2367 or $text =~ /[<>]/) {
2368 return 'glob(' . single_delim('qq', '"', $text) . ')';
2370 return '<' . $text . '>';
2374 # Truncate is special because OPf_SPECIAL makes a bareword first arg
2375 # be a filehandle. This could probably be better fixed in the core
2376 # by moving the GV lookup into ck_truc.
2382 my $parens = ($cx >= 5) || $self->{'parens'};
2383 my $kid = $op->first->sibling;
2385 if ($op->flags & OPf_SPECIAL) {
2386 # $kid is an OP_CONST
2387 $fh = $self->const_sv($kid)->PV;
2389 $fh = $self->deparse($kid, 6);
2390 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2392 my $len = $self->deparse($kid->sibling, 6);
2394 return "truncate($fh, $len)";
2396 return "truncate $fh, $len";
2402 my($op, $cx, $name) = @_;
2404 my $kid = $op->first->sibling;
2406 if ($op->flags & OPf_STACKED) {
2408 $indir = $indir->first; # skip rv2gv
2409 if (is_scope($indir)) {
2410 $indir = "{" . $self->deparse($indir, 0) . "}";
2411 $indir = "{;}" if $indir eq "{}";
2412 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
2413 $indir = $self->const_sv($indir)->PV;
2415 $indir = $self->deparse($indir, 24);
2417 $indir = $indir . " ";
2418 $kid = $kid->sibling;
2420 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
2421 $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
2424 elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
2425 $indir = '{$b cmp $a} ';
2427 for (; !null($kid); $kid = $kid->sibling) {
2428 $expr = $self->deparse($kid, 6);
2432 if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
2433 $name2 = 'reverse sort';
2435 if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
2436 return "$exprs[0] = $name2 $indir $exprs[0]";
2439 my $args = $indir . join(", ", @exprs);
2440 if ($indir ne "" and $name eq "sort") {
2441 # We don't want to say "sort(f 1, 2, 3)", since perl -w will
2442 # give bareword warnings in that case. Therefore if context
2443 # requires, we'll put parens around the outside "(sort f 1, 2,
2444 # 3)". Unfortunately, we'll currently think the parens are
2445 # necessary more often that they really are, because we don't
2446 # distinguish which side of an assignment we're on.
2448 return "($name2 $args)";
2450 return "$name2 $args";
2453 return $self->maybe_parens_func($name2, $args, $cx, 5);
2458 sub pp_prtf { indirop(@_, "printf") }
2459 sub pp_print { indirop(@_, "print") }
2460 sub pp_say { indirop(@_, "say") }
2461 sub pp_sort { indirop(@_, "sort") }
2465 my($op, $cx, $name) = @_;
2467 my $kid = $op->first; # this is the (map|grep)start
2468 $kid = $kid->first->sibling; # skip a pushmark
2469 my $code = $kid->first; # skip a null
2470 if (is_scope $code) {
2471 $code = "{" . $self->deparse($code, 0) . "} ";
2473 $code = $self->deparse($code, 24) . ", ";
2475 $kid = $kid->sibling;
2476 for (; !null($kid); $kid = $kid->sibling) {
2477 $expr = $self->deparse($kid, 6);
2478 push @exprs, $expr if defined $expr;
2480 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2483 sub pp_mapwhile { mapop(@_, "map") }
2484 sub pp_grepwhile { mapop(@_, "grep") }
2485 sub pp_mapstart { baseop(@_, "map") }
2486 sub pp_grepstart { baseop(@_, "grep") }
2492 my $kid = $op->first->sibling; # skip pushmark
2494 my $local = "either"; # could be local(...), my(...), state(...) or our(...)
2495 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2496 # This assumes that no other private flags equal 128, and that
2497 # OPs that store things other than flags in their op_private,
2498 # like OP_AELEMFAST, won't be immediate children of a list.
2500 # OP_ENTERSUB can break this logic, so check for it.
2501 # I suspect that open and exit can too.
2503 if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
2504 or $lop->name eq "undef")
2505 or $lop->name eq "entersub"
2506 or $lop->name eq "exit"
2507 or $lop->name eq "open")
2509 $local = ""; # or not
2512 if ($lop->name =~ /^pad[ash]v$/) {
2513 if ($lop->private & OPpPAD_STATE) { # state()
2514 ($local = "", last) if $local =~ /^(?:local|our|my)$/;
2517 ($local = "", last) if $local =~ /^(?:local|our|state)$/;
2520 } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
2521 && $lop->private & OPpOUR_INTRO
2522 or $lop->name eq "null" && $lop->first->name eq "gvsv"
2523 && $lop->first->private & OPpOUR_INTRO) { # our()
2524 ($local = "", last) if $local =~ /^(?:my|local|state)$/;
2526 } elsif ($lop->name ne "undef"
2527 # specifically avoid the "reverse sort" optimisation,
2528 # where "reverse" is nullified
2529 && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
2532 ($local = "", last) if $local =~ /^(?:my|our|state)$/;
2536 $local = "" if $local eq "either"; # no point if it's all undefs
2537 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2538 for (; !null($kid); $kid = $kid->sibling) {
2540 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2545 $self->{'avoid_local'}{$$lop}++;
2546 $expr = $self->deparse($kid, 6);
2547 delete $self->{'avoid_local'}{$$lop};
2549 $expr = $self->deparse($kid, 6);
2554 return "$local(" . join(", ", @exprs) . ")";
2556 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2560 sub is_ifelse_cont {
2562 return ($op->name eq "null" and class($op) eq "UNOP"
2563 and $op->first->name =~ /^(and|cond_expr)$/
2564 and is_scope($op->first->first->sibling));
2570 my $cond = $op->first;
2571 my $true = $cond->sibling;
2572 my $false = $true->sibling;
2573 my $cuddle = $self->{'cuddle'};
2574 unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
2575 (is_scope($false) || is_ifelse_cont($false))
2576 and $self->{'expand'} < 7) {
2577 $cond = $self->deparse($cond, 8);
2578 $true = $self->deparse($true, 6);
2579 $false = $self->deparse($false, 8);
2580 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2583 $cond = $self->deparse($cond, 1);
2584 $true = $self->deparse($true, 0);
2585 my $head = "if ($cond) {\n\t$true\n\b}";
2587 while (!null($false) and is_ifelse_cont($false)) {
2588 my $newop = $false->first;
2589 my $newcond = $newop->first;
2590 my $newtrue = $newcond->sibling;
2591 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2592 $newcond = $self->deparse($newcond, 1);
2593 $newtrue = $self->deparse($newtrue, 0);
2594 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2596 if (!null($false)) {
2597 $false = $cuddle . "else {\n\t" .
2598 $self->deparse($false, 0) . "\n\b}\cK";
2602 return $head . join($cuddle, "", @elsifs) . $false;
2606 my ($self, $op, $cx) = @_;
2607 my $cond = $op->first;
2608 my $true = $cond->sibling;
2610 return $self->deparse($true, $cx);
2615 my($op, $cx, $init) = @_;
2616 my $enter = $op->first;
2617 my $kid = $enter->sibling;
2618 local(@$self{qw'curstash warnings hints hinthash'})
2619 = @$self{qw'curstash warnings hints hinthash'};
2624 if ($kid->name eq "lineseq") { # bare or infinite loop
2625 if ($kid->last->name eq "unstack") { # infinite
2626 $head = "while (1) "; # Can't use for(;;) if there's a continue
2632 } elsif ($enter->name eq "enteriter") { # foreach
2633 my $ary = $enter->first->sibling; # first was pushmark
2634 my $var = $ary->sibling;
2635 if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
2636 # "reverse" was optimised away
2637 $ary = listop($self, $ary->first->sibling, 1, 'reverse');
2638 } elsif ($enter->flags & OPf_STACKED
2639 and not null $ary->first->sibling->sibling)
2641 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2642 $self->deparse($ary->first->sibling->sibling, 9);
2644 $ary = $self->deparse($ary, 1);
2647 if ($enter->flags & OPf_SPECIAL) { # thread special var
2648 $var = $self->pp_threadsv($enter, 1);
2649 } else { # regular my() variable
2650 $var = $self->pp_padsv($enter, 1);
2652 } elsif ($var->name eq "rv2gv") {
2653 $var = $self->pp_rv2sv($var, 1);
2654 if ($enter->private & OPpOUR_INTRO) {
2655 # our declarations don't have package names
2656 $var =~ s/^(.).*::/$1/;
2659 } elsif ($var->name eq "gv") {
2660 $var = "\$" . $self->deparse($var, 1);
2662 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2663 if (!is_state $body->first and $body->first->name ne "stub") {
2664 confess unless $var eq '$_';
2665 $body = $body->first;
2666 return $self->deparse($body, 2) . " foreach ($ary)";
2668 $head = "foreach $var ($ary) ";
2669 } elsif ($kid->name eq "null") { # while/until
2671 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2672 $cond = $self->deparse($kid->first, 1);
2673 $head = "$name ($cond) ";
2674 $body = $kid->first->sibling;
2675 } elsif ($kid->name eq "stub") { # bare and empty
2676 return "{;}"; # {} could be a hashref
2678 # If there isn't a continue block, then the next pointer for the loop
2679 # will point to the unstack, which is kid's last child, except
2680 # in a bare loop, when it will point to the leaveloop. When neither of
2681 # these conditions hold, then the second-to-last child is the continue
2682 # block (or the last in a bare loop).
2683 my $cont_start = $enter->nextop;
2685 if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
2687 $cont = $body->last;
2689 $cont = $body->first;
2690 while (!null($cont->sibling->sibling)) {
2691 $cont = $cont->sibling;
2694 my $state = $body->first;
2695 my $cuddle = $self->{'cuddle'};
2697 for (; $$state != $$cont; $state = $state->sibling) {
2698 push @states, $state;
2700 $body = $self->lineseq(undef, @states);
2701 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2702 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2705 $cont = $cuddle . "continue {\n\t" .
2706 $self->deparse($cont, 0) . "\n\b}\cK";
2709 return "" if !defined $body;
2711 $head = "for ($init; $cond;) ";
2714 $body = $self->deparse($body, 0);
2716 $body =~ s/;?$/;\n/;
2718 return $head . "{\n\t" . $body . "\b}" . $cont;
2721 sub pp_leaveloop { shift->loop_common(@_, "") }
2726 my $init = $self->deparse($op, 1);
2727 return $self->loop_common($op->sibling->first->sibling, $cx, $init);
2732 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2735 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2736 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2737 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
2738 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
2743 if (class($op) eq "OP") {
2745 return $self->{'ex_const'} if $op->targ == OP_CONST;
2746 } elsif ($op->first->name eq "pushmark") {
2747 return $self->pp_list($op, $cx);
2748 } elsif ($op->first->name eq "enter") {
2749 return $self->pp_leave($op, $cx);
2750 } elsif ($op->first->name eq "leave") {
2751 return $self->pp_leave($op->first, $cx);
2752 } elsif ($op->first->name eq "scope") {
2753 return $self->pp_scope($op->first, $cx);
2754 } elsif ($op->targ == OP_STRINGIFY) {
2755 return $self->dquote($op, $cx);
2756 } elsif (!null($op->first->sibling) and
2757 $op->first->sibling->name eq "readline" and
2758 $op->first->sibling->flags & OPf_STACKED) {
2759 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2760 . $self->deparse($op->first->sibling, 7),
2762 } elsif (!null($op->first->sibling) and
2763 $op->first->sibling->name eq "trans" and
2764 $op->first->sibling->flags & OPf_STACKED) {
2765 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2766 . $self->deparse($op->first->sibling, 20),
2768 } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
2769 return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2770 } elsif (!null($op->first->sibling) and
2771 $op->first->sibling->name eq "null" and
2772 class($op->first->sibling) eq "UNOP" and
2773 $op->first->sibling->first->flags & OPf_STACKED and
2774 $op->first->sibling->first->name eq "rcatline") {
2775 return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
2776 . $self->deparse($op->first->sibling, 18),
2779 return $self->deparse($op->first, $cx);
2786 return $self->padname_sv($targ)->PVX;
2792 return substr($self->padname($op->targ), 1); # skip $/@/%
2798 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2801 sub pp_padav { pp_padsv(@_) }
2802 sub pp_padhv { pp_padsv(@_) }
2807 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2808 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2809 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2816 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2822 if (class($op) eq "PADOP") {
2823 return $self->padval($op->padix);
2824 } else { # class($op) eq "SVOP"
2832 my $gv = $self->gv_or_padgv($op);
2833 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2834 $self->gv_name($gv)));
2840 my $gv = $self->gv_or_padgv($op);
2841 return $self->gv_name($gv);
2848 if ($op->flags & OPf_SPECIAL) { # optimised PADAV
2849 $name = $self->padname($op->targ);
2853 my $gv = $self->gv_or_padgv($op);
2854 $name = $self->gv_name($gv);
2855 $name = $self->{'curstash'}."::$name"
2856 if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2857 $name = '$' . $name;
2860 return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
2865 my($op, $cx, $type) = @_;
2867 if (class($op) eq 'NULL' || !$op->can("first")) {
2868 carp("Unexpected op in pp_rv2x");
2871 my $kid = $op->first;
2872 if ($kid->name eq "gv") {
2873 return $self->stash_variable($type, $self->deparse($kid, 0));
2874 } elsif (is_scalar $kid) {
2875 my $str = $self->deparse($kid, 0);
2876 if ($str =~ /^\$([^\w\d])\z/) {
2877 # "$$+" isn't a legal way to write the scalar dereference
2878 # of $+, since the lexer can't tell you aren't trying to
2879 # do something like "$$ + 1" to get one more than your
2880 # PID. Either "${$+}" or "$${+}" are workable
2881 # disambiguations, but if the programmer did the former,
2882 # they'd be in the "else" clause below rather than here.
2883 # It's not clear if this should somehow be unified with
2884 # the code in dq and re_dq that also adds lexer
2885 # disambiguation braces.
2886 $str = '$' . "{$1}"; #'
2888 return $type . $str;
2890 return $type . "{" . $self->deparse($kid, 0) . "}";
2894 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2895 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2896 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2902 if ($op->first->name eq "padav") {
2903 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2905 return $self->maybe_local($op, $cx,
2906 $self->rv2x($op->first, $cx, '$#'));
2910 # skip down to the old, ex-rv2cv
2912 my ($self, $op, $cx) = @_;
2913 if (!null($op->first) && $op->first->name eq 'null' &&
2914 $op->first->targ eq OP_LIST)
2916 return $self->rv2x($op->first->first->sibling, $cx, "&")
2919 return $self->rv2x($op, $cx, "")
2925 my($cx, @list) = @_;
2926 my @a = map $self->const($_, 6), @list;
2931 } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
2932 # collapse (-1,0,1,2) into (-1..2)
2933 my ($s, $e) = @a[0,-1];
2935 return $self->maybe_parens("$s..$e", $cx, 9)
2936 unless grep $i++ != $_, @a;
2938 return $self->maybe_parens(join(", ", @a), $cx, 6);
2944 my $kid = $op->first;
2945 if ($kid->name eq "const") { # constant list
2946 my $av = $self->const_sv($kid);
2947 return $self->list_const($cx, $av->ARRAY);
2949 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2953 sub is_subscriptable {
2955 if ($op->name =~ /^[ahg]elem/) {
2957 } elsif ($op->name eq "entersub") {
2958 my $kid = $op->first;
2959 return 0 unless null $kid->sibling;
2961 $kid = $kid->sibling until null $kid->sibling;
2962 return 0 if is_scope($kid);
2964 return 0 if $kid->name eq "gv";
2965 return 0 if is_scalar($kid);
2966 return is_subscriptable($kid);
2972 sub elem_or_slice_array_name
2975 my ($array, $left, $padname, $allow_arrow) = @_;
2977 if ($array->name eq $padname) {
2978 return $self->padany($array);
2979 } elsif (is_scope($array)) { # ${expr}[0]
2980 return "{" . $self->deparse($array, 0) . "}";
2981 } elsif ($array->name eq "gv") {
2982 $array = $self->gv_name($self->gv_or_padgv($array));
2983 if ($array !~ /::/) {
2984 my $prefix = ($left eq '[' ? '@' : '%');
2985 $array = $self->{curstash}.'::'.$array
2986 if $self->lex_in_scope($prefix . $array);
2989 } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
2990 return $self->deparse($array, 24);
2996 sub elem_or_slice_single_index
3001 $idx = $self->deparse($idx, 1);
3003 # Outer parens in an array index will confuse perl
3004 # if we're interpolating in a regular expression, i.e.
3005 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
3007 # If $self->{parens}, then an initial '(' will
3008 # definitely be paired with a final ')'. If
3009 # !$self->{parens}, the misleading parens won't
3010 # have been added in the first place.
3012 # [You might think that we could get "(...)...(...)"
3013 # where the initial and final parens do not match
3014 # each other. But we can't, because the above would
3015 # only happen if there's an infix binop between the
3016 # two pairs of parens, and *that* means that the whole
3017 # expression would be parenthesized as well.]
3019 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
3021 # Hash-element braces will autoquote a bareword inside themselves.
3022 # We need to make sure that C<$hash{warn()}> doesn't come out as
3023 # C<$hash{warn}>, which has a quite different meaning. Currently
3024 # B::Deparse will always quote strings, even if the string was a
3025 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
3026 # for constant strings.) So we can cheat slightly here - if we see
3027 # a bareword, we know that it is supposed to be a function call.
3029 $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
3036 my ($op, $cx, $left, $right, $padname) = @_;
3037 my($array, $idx) = ($op->first, $op->first->sibling);
3039 $idx = $self->elem_or_slice_single_index($idx);
3041 unless ($array->name eq $padname) { # Maybe this has been fixed
3042 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
3044 if (my $array_name=$self->elem_or_slice_array_name
3045 ($array, $left, $padname, 1)) {
3046 return "\$" . $array_name . $left . $idx . $right;
3048 # $x[20][3]{hi} or expr->[20]
3049 my $arrow = is_subscriptable($array) ? "" : "->";
3050 return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
3055 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
3056 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
3061 my($glob, $part) = ($op->first, $op->last);
3062 $glob = $glob->first; # skip rv2gv
3063 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
3064 my $scope = is_scope($glob);
3065 $glob = $self->deparse($glob, 0);
3066 $part = $self->deparse($part, 1);
3067 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
3072 my ($op, $cx, $left, $right, $regname, $padname) = @_;
3074 my(@elems, $kid, $array, $list);
3075 if (class($op) eq "LISTOP") {
3077 } else { # ex-hslice inside delete()
3078 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
3082 $array = $array->first
3083 if $array->name eq $regname or $array->name eq "null";
3084 $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
3085 $kid = $op->first->sibling; # skip pushmark
3086 if ($kid->name eq "list") {
3087 $kid = $kid->first->sibling; # skip list, pushmark
3088 for (; !null $kid; $kid = $kid->sibling) {
3089 push @elems, $self->deparse($kid, 6);
3091 $list = join(", ", @elems);
3093 $list = $self->elem_or_slice_single_index($kid);
3095 return "\@" . $array . $left . $list . $right;
3098 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
3099 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
3104 my $idx = $op->first;
3105 my $list = $op->last;
3107 $list = $self->deparse($list, 1);
3108 $idx = $self->deparse($idx, 1);
3109 return "($list)" . "[$idx]";
3114 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
3119 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
3125 my $kid = $op->first->sibling; # skip pushmark
3126 my($meth, $obj, @exprs);
3127 if ($kid->name eq "list" and want_list $kid) {
3128 # When an indirect object isn't a bareword but the args are in
3129 # parens, the parens aren't part of the method syntax (the LLAFR
3130 # doesn't apply), but they make a list with OPf_PARENS set that
3131 # doesn't get flattened by the append_elem that adds the method,
3132 # making a (object, arg1, arg2, ...) list where the object
3133 # usually is. This can be distinguished from
3134 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
3135 # object) because in the later the list is in scalar context
3136 # as the left side of -> always is, while in the former
3137 # the list is in list context as method arguments always are.
3138 # (Good thing there aren't method prototypes!)
3139 $meth = $kid->sibling;
3140 $kid = $kid->first->sibling; # skip pushmark
3142 $kid = $kid->sibling;
3143 for (; not null $kid; $kid = $kid->sibling) {
3148 $kid = $kid->sibling;
3149 for (; !null ($kid->sibling) && $kid->name ne "method_named";
3150 $kid = $kid->sibling) {
3156 if ($meth->name eq "method_named") {
3157 $meth = $self->const_sv($meth)->PV;
3159 $meth = $meth->first;
3160 if ($meth->name eq "const") {
3161 # As of 5.005_58, this case is probably obsoleted by the
3162 # method_named case above
3163 $meth = $self->const_sv($meth)->PV; # needs to be bare
3167 return { method => $meth, variable_method => ref($meth),
3168 object => $obj, args => \@exprs };
3171 # compat function only
3174 my $info = $self->_method(@_);
3175 return $self->e_method( $self->_method(@_) );
3179 my ($self, $info) = @_;
3180 my $obj = $self->deparse($info->{object}, 24);
3182 my $meth = $info->{method};
3183 $meth = $self->deparse($meth, 1) if $info->{variable_method};
3184 my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
3185 my $kid = $obj . "->" . $meth;
3187 return $kid . "(" . $args . ")"; # parens mandatory
3193 # returns "&" if the prototype doesn't match the args,
3194 # or ("", $args_after_prototype_demunging) if it does.
3197 return "&" if $self->{'noproto'};
3198 my($proto, @args) = @_;
3202 # An unbackslashed @ or % gobbles up the rest of the args
3203 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
3205 $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//;
3208 return "&" if @args;
3209 } elsif ($chr eq ";") {
3211 } elsif ($chr eq "@" or $chr eq "%") {
3212 push @reals, map($self->deparse($_, 6), @args);
3218 if (want_scalar $arg) {
3219 push @reals, $self->deparse($arg, 6);
3223 } elsif ($chr eq "&") {
3224 if ($arg->name =~ /^(s?refgen|undef)$/) {
3225 push @reals, $self->deparse($arg, 6);
3229 } elsif ($chr eq "*") {
3230 if ($arg->name =~ /^s?refgen$/
3231 and $arg->first->first->name eq "rv2gv")
3233 $real = $arg->first->first; # skip refgen, null
3234 if ($real->first->name eq "gv") {
3235 push @reals, $self->deparse($real, 6);
3237 push @reals, $self->deparse($real->first, 6);
3242 } elsif (substr($chr, 0, 1) eq "\\") {
3244 if ($arg->name =~ /^s?refgen$/ and
3245 !null($real = $arg->first) and
3246 ($chr =~ /\$/ && is_scalar($real->first)
3248 && class($real->first->sibling) ne 'NULL'
3249 && $real->first->sibling->name
3252 && class($real->first->sibling) ne 'NULL'
3253 && $real->first->sibling->name
3255 #or ($chr =~ /&/ # This doesn't work
3256 # && $real->first->name eq "rv2cv")
3258 && $real->first->name eq "rv2gv")))
3260 push @reals, $self->deparse($real, 6);
3267 return "&" if $proto and !$doneok; # too few args and no `;'
3268 return "&" if @args; # too many args
3269 return ("", join ", ", @reals);
3275 return $self->e_method($self->_method($op, $cx))
3276 unless null $op->first->sibling;
3280 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
3282 } elsif ($op->private & OPpENTERSUB_AMPER) {
3286 $kid = $kid->first->sibling; # skip ex-list, pushmark
3287 for (; not null $kid->sibling; $kid = $kid->sibling) {
3292 if (is_scope($kid)) {
3294 $kid = "{" . $self->deparse($kid, 0) . "}";
3295 } elsif ($kid->first->name eq "gv") {
3296 my $gv = $self->gv_or_padgv($kid->first);
3297 if (class($gv->CV) ne "SPECIAL") {
3298 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
3300 $simple = 1; # only calls of named functions can be prototyped
3301 $kid = $self->deparse($kid, 24);
3303 if ($kid eq 'main::') {
3305 } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
3306 $kid = single_delim("q", "'", $kid) . '->';
3309 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
3311 $kid = $self->deparse($kid, 24);
3314 my $arrow = is_subscriptable($kid->first) ? "" : "->";
3315 $kid = $self->deparse($kid, 24) . $arrow;
3318 # Doesn't matter how many prototypes there are, if
3319 # they haven't happened yet!
3323 no warnings 'uninitialized';
3324 $declared = exists $self->{'subs_declared'}{$kid}
3326 defined &{ ${$self->{'curstash'}."::"}{$kid} }
3328 $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
3329 && defined prototype $self->{'curstash'}."::".$kid
3331 if (!$declared && defined($proto)) {
3332 # Avoid "too early to check prototype" warning
3333 ($amper, $proto) = ('&');
3338 if ($declared and defined $proto and not $amper) {
3339 ($amper, $args) = $self->check_proto($proto, @exprs);
3340 if ($amper eq "&") {
3341 $args = join(", ", map($self->deparse($_, 6), @exprs));
3344 $args = join(", ", map($self->deparse($_, 6), @exprs));
3346 if ($prefix or $amper) {
3347 if ($op->flags & OPf_STACKED) {
3348 return $prefix . $amper . $kid . "(" . $args . ")";
3350 return $prefix . $amper. $kid;
3353 # glob() invocations can be translated into calls of
3354 # CORE::GLOBAL::glob with a second parameter, a number.
3356 if ($kid eq "CORE::GLOBAL::glob") {
3358 $args =~ s/\s*,[^,]+$//;
3361 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
3362 # so it must have been translated from a keyword call. Translate
3364 $kid =~ s/^CORE::GLOBAL:://;
3366 my $dproto = defined($proto) ? $proto : "undefined";
3368 return "$kid(" . $args . ")";
3369 } elsif ($dproto eq "") {
3371 } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
3372 # is_scalar is an excessively conservative test here:
3373 # really, we should be comparing to the precedence of the
3374 # top operator of $exprs[0] (ala unop()), but that would
3375 # take some major code restructuring to do right.
3376 return $self->maybe_parens_func($kid, $args, $cx, 16);
3377 } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
3378 return $self->maybe_parens_func($kid, $args, $cx, 5);
3380 return "$kid(" . $args . ")";
3385 sub pp_enterwrite { unop(@_, "write") }
3387 # escape things that cause interpolation in double quotes,
3388 # but not character escapes
3391 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
3399 # Matches any string which is balanced with respect to {braces}
3410 # the same, but treat $|, $), $( and $ at the end of the string differently
3424 (\(\?\??\{$bal\}\)) # $4
3430 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3435 # This is for regular expressions with the /x modifier
3436 # We have to leave comments unmangled.
3437 sub re_uninterp_extended {
3450 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
3451 | \#[^\n]* # (skip over comments)
3458 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3464 my %unctrl = # portable to to EBCDIC
3466 "\c@" => '\c@', # unused
3493 "\c[" => '\c[', # unused
3494 "\c\\" => '\c\\', # unused
3495 "\c]" => '\c]', # unused
3496 "\c_" => '\c_', # unused
3499 # character escapes, but not delimiters that might need to be escaped
3500 sub escape_str { # ASCII, UTF8
3502 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3504 # $str =~ s/\cH/\\b/g; # \b means something different in a regex
3510 $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
3511 $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
3515 # For regexes with the /x modifier.
3516 # Leave whitespace unmangled.
3517 sub escape_extended_re {
3519 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3520 $str =~ s/([[:^print:]])/
3521 ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
3522 $str =~ s/\n/\n\f/g;
3526 # Don't do this for regexen
3529 $str =~ s/\\/\\\\/g;
3533 # Remove backslashes which precede literal control characters,
3534 # to avoid creating ambiguity when we escape the latter.
3538 # the insane complexity here is due to the behaviour of "\c\"
3539 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
3543 sub balanced_delim {
3545 my @str = split //, $str;
3546 my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
3547 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3548 ($open, $close) = @$ar;
3549 $fail = 0; $cnt = 0; $last_bs = 0;
3552 $fail = 1 if $last_bs;
3554 } elsif ($c eq $close) {
3555 $fail = 1 if $last_bs;
3563 $last_bs = $c eq '\\';
3565 $fail = 1 if $cnt != 0;
3566 return ($open, "$open$str$close") if not $fail;
3572 my($q, $default, $str) = @_;
3573 return "$default$str$default" if $default and index($str, $default) == -1;
3575 (my $succeed, $str) = balanced_delim($str);
3576 return "$q$str" if $succeed;
3578 for my $delim ('/', '"', '#') {
3579 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3582 $str =~ s/$default/\\$default/g;
3583 return "$default$str$default";
3591 BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
3593 # Split a floating point number into an integer mantissa and a binary
3594 # exponent. Assumes you've already made sure the number isn't zero or
3595 # some weird infinity or NaN.
3599 if ($f == int($f)) {
3600 while ($f % 2 == 0) {
3605 while ($f != int($f)) {
3610 my $mantissa = sprintf("%.0f", $f);
3611 return ($mantissa, $exponent);
3617 if ($self->{'use_dumper'}) {
3618 return $self->const_dumper($sv, $cx);
3620 if (class($sv) eq "SPECIAL") {
3621 # sv_undef, sv_yes, sv_no
3622 return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
3623 } elsif (class($sv) eq "NULL") {
3626 # convert a version object into the "v1.2.3" string in its V magic
3627 if ($sv->FLAGS & SVs_RMG) {
3628 for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
3629 return $mg->PTR if $mg->TYPE eq 'V';
3633 if ($sv->FLAGS & SVf_IOK) {
3634 my $str = $sv->int_value;
3635 $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
3637 } elsif ($sv->FLAGS & SVf_NOK) {
3640 if (pack("F", $nv) eq pack("F", 0)) {
3645 return $self->maybe_parens("-.0", $cx, 21);
3647 } elsif (1/$nv == 0) {
3650 return $self->maybe_parens("9**9**9", $cx, 22);
3653 return $self->maybe_parens("-9**9**9", $cx, 21);
3655 } elsif ($nv != $nv) {
3657 if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
3659 return "sin(9**9**9)";
3660 } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
3662 return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
3665 my $hex = unpack("h*", pack("F", $nv));
3666 return qq'unpack("F", pack("h*", "$hex"))';
3669 # first, try the default stringification
3672 # failing that, try using more precision
3673 $str = sprintf("%.${max_prec}g", $nv);
3674 # if (pack("F", $str) ne pack("F", $nv)) {
3676 # not representable in decimal with whatever sprintf()
3677 # and atof() Perl is using here.
3678 my($mant, $exp) = split_float($nv);
3679 return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
3682 $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
3684 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3686 if (class($ref) eq "AV") {
3687 return "[" . $self->list_const(2, $ref->ARRAY) . "]";
3688 } elsif (class($ref) eq "HV") {
3689 my %hash = $ref->ARRAY;
3691 for my $k (sort keys %hash) {
3692 push @elts, "$k => " . $self->const($hash{$k}, 6);
3694 return "{" . join(", ", @elts) . "}";
3695 } elsif (class($ref) eq "CV") {
3696 return "sub " . $self->deparse_sub($ref);
3698 if ($ref->FLAGS & SVs_SMG) {
3699 for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
3700 if ($mg->TYPE eq 'r') {
3701 my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
3702 return single_delim("qr", "", $re);
3707 return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
3708 } elsif ($sv->FLAGS & SVf_POK) {
3710 if ($str =~ /[[:^print:]]/) {
3711 return single_delim("qq", '"', uninterp escape_str unback $str);
3713 return single_delim("q", "'", unback $str);
3723 my $ref = $sv->object_2svref();
3724 my $dumper = Data::Dumper->new([$$ref], ['$v']);
3725 $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
3726 my $str = $dumper->Dump();
3727 if ($str =~ /^\$v/) {
3728 return '${my ' . $str . ' \$v}';
3738 # the constant could be in the pad (under useithreads)
3739 $sv = $self->padval($op->targ) unless $$sv;
3746 if ($op->private & OPpCONST_ARYBASE) {
3749 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3750 # return $self->const_sv($op)->PV;
3752 my $sv = $self->const_sv($op);
3753 return $self->const($sv, $cx);
3759 my $type = $op->name;
3760 if ($type eq "const") {
3761 return '$[' if $op->private & OPpCONST_ARYBASE;
3762 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3763 } elsif ($type eq "concat") {
3764 my $first = $self->dq($op->first);
3765 my $last = $self->dq($op->last);
3767 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
3768 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3769 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
3770 || ($last =~ /^[:'{\[\w_]/ && #'
3771 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3773 return $first . $last;
3774 } elsif ($type eq "uc") {
3775 return '\U' . $self->dq($op->first->sibling) . '\E';
3776 } elsif ($type eq "lc") {
3777 return '\L' . $self->dq($op->first->sibling) . '\E';
3778 } elsif ($type eq "ucfirst") {
3779 return '\u' . $self->dq($op->first->sibling);
3780 } elsif ($type eq "lcfirst") {
3781 return '\l' . $self->dq($op->first->sibling);
3782 } elsif ($type eq "quotemeta") {
3783 return '\Q' . $self->dq($op->first->sibling) . '\E';
3784 } elsif ($type eq "join") {
3785 return $self->deparse($op->last, 26); # was join($", @ary)
3787 return $self->deparse($op, 26);
3794 # skip pushmark if it exists (readpipe() vs ``)
3795 my $child = $op->first->sibling->isa('B::NULL')
3796 ? $op->first->first : $op->first->sibling;
3797 return single_delim("qx", '`', $self->dq($child));
3803 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3804 return $self->deparse($kid, $cx) if $self->{'unquote'};
3805 $self->maybe_targmy($kid, $cx,
3806 sub {single_delim("qq", '"', $self->dq($_[1]))});
3809 # OP_STRINGIFY is a listop, but it only ever has one arg
3810 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3812 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3813 # note that tr(from)/to/ is OK, but not tr/from/(to)
3815 my($from, $to) = @_;
3816 my($succeed, $delim);
3817 if ($from !~ m[/] and $to !~ m[/]) {
3818 return "/$from/$to/";
3819 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3820 if (($succeed, $to) = balanced_delim($to) and $succeed) {
3823 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3824 return "$from$delim$to$delim" if index($to, $delim) == -1;
3827 return "$from/$to/";
3830 for $delim ('/', '"', '#') { # note no '
3831 return "$delim$from$delim$to$delim"
3832 if index($to . $from, $delim) == -1;
3834 $from =~ s[/][\\/]g;
3836 return "/$from/$to/";
3840 # Only used by tr///, so backslashes hyphens
3843 if ($n == ord '\\') {
3845 } elsif ($n == ord "-") {
3847 } elsif ($n >= ord(' ') and $n <= ord('~')) {
3849 } elsif ($n == ord "\a") {
3851 } elsif ($n == ord "\b") {
3853 } elsif ($n == ord "\t") {
3855 } elsif ($n == ord "\n") {
3857 } elsif ($n == ord "\e") {
3859 } elsif ($n == ord "\f") {
3861 } elsif ($n == ord "\r") {
3863 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3864 return '\\c' . chr(ord("@") + $n);
3866 # return '\x' . sprintf("%02x", $n);
3867 return '\\' . sprintf("%03o", $n);
3873 my($str, $c, $tr) = ("");
3874 for ($c = 0; $c < @chars; $c++) {
3877 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3878 $chars[$c + 2] == $tr + 2)
3880 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3883 $str .= pchr($chars[$c]);
3889 sub tr_decode_byte {
3890 my($table, $flags) = @_;
3891 my(@table) = unpack("s*", $table);
3892 splice @table, 0x100, 1; # Number of subsequent elements
3893 my($c, $tr, @from, @to, @delfrom, $delhyphen);
3894 if ($table[ord "-"] != -1 and
3895 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3897 $tr = $table[ord "-"];
3898 $table[ord "-"] = -1;
3902 } else { # -2 ==> delete
3906 for ($c = 0; $c < @table; $c++) {
3909 push @from, $c; push @to, $tr;
3910 } elsif ($tr == -2) {
3914 @from = (@from, @delfrom);
3915 if ($flags & OPpTRANS_COMPLEMENT) {
3918 @from{@from} = (1) x @from;
3919 for ($c = 0; $c < 256; $c++) {
3920 push @newfrom, $c unless $from{$c};
3924 unless ($flags & OPpTRANS_DELETE || !@to) {
3925 pop @to while $#to and $to[$#to] == $to[$#to -1];
3928 $from = collapse(@from);
3929 $to = collapse(@to);
3930 $from .= "-" if $delhyphen;
3931 return ($from, $to);
3936 if ($x == ord "-") {
3938 } elsif ($x == ord "\\") {
3945 # XXX This doesn't yet handle all cases correctly either
3947 sub tr_decode_utf8 {
3948 my($swash_hv, $flags) = @_;
3949 my %swash = $swash_hv->ARRAY;
3951 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3952 my $none = $swash{"NONE"}->IV;
3953 my $extra = $none + 1;
3954 my(@from, @delfrom, @to);
3956 foreach $line (split /\n/, $swash{'LIST'}->PV) {
3957 my($min, $max, $result) = split(/\t/, $line);
3964 $result = hex $result;
3965 if ($result == $extra) {
3966 push @delfrom, [$min, $max];
3968 push @from, [$min, $max];
3969 push @to, [$result, $result + $max - $min];
3972 for my $i (0 .. $#from) {
3973 if ($from[$i][0] == ord '-') {
3974 unshift @from, splice(@from, $i, 1);
3975 unshift @to, splice(@to, $i, 1);
3977 } elsif ($from[$i][1] == ord '-') {
3980 unshift @from, ord '-';
3981 unshift @to, ord '-';
3985 for my $i (0 .. $#delfrom) {
3986 if ($delfrom[$i][0] == ord '-') {
3987 push @delfrom, splice(@delfrom, $i, 1);
3989 } elsif ($delfrom[$i][1] == ord '-') {
3991 push @delfrom, ord '-';
3995 if (defined $final and $to[$#to][1] != $final) {
3996 push @to, [$final, $final];
3998 push @from, @delfrom;
3999 if ($flags & OPpTRANS_COMPLEMENT) {
4002 for my $i (0 .. $#from) {
4003 push @newfrom, [$next, $from[$i][0] - 1];
4004 $next = $from[$i][1] + 1;
4007 for my $range (@newfrom) {
4008 if ($range->[0] <= $range->[1]) {
4013 my($from, $to, $diff);
4014 for my $chunk (@from) {
4015 $diff = $chunk->[1] - $chunk->[0];
4017 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
4018 } elsif ($diff == 1) {
4019 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
4021 $from .= tr_chr($chunk->[0]);
4024 for my $chunk (@to) {
4025 $diff = $chunk->[1] - $chunk->[0];
4027 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
4028 } elsif ($diff == 1) {
4029 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
4031 $to .= tr_chr($chunk->[0]);
4034 #$final = sprintf("%04x", $final) if defined $final;
4035 #$none = sprintf("%04x", $none) if defined $none;
4036 #$extra = sprintf("%04x", $extra) if defined $extra;
4037 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
4038 #print STDERR $swash{'LIST'}->PV;
4039 return (escape_str($from), escape_str($to));
4046 if (class($op) eq "PVOP") {
4047 ($from, $to) = tr_decode_byte($op->pv, $op->private);
4048 } else { # class($op) eq "SVOP"
4049 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
4052 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
4053 $flags .= "d" if $op->private & OPpTRANS_DELETE;
4054 $to = "" if $from eq $to and $flags eq "";
4055 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
4056 return "tr" . double_delim($from, $to) . $flags;
4059 # Like dq(), but different
4062 my ($op, $extended) = @_;
4064 my $type = $op->name;
4065 if ($type eq "const") {
4066 return '$[' if $op->private & OPpCONST_ARYBASE;
4067 my $unbacked = re_unback($self->const_sv($op)->as_string);
4068 return re_uninterp_extended(escape_extended_re($unbacked))
4070 return re_uninterp(escape_str($unbacked));
4071 } elsif ($type eq "concat") {
4072 my $first = $self->re_dq($op->first, $extended);
4073 my $last = $self->re_dq($op->last, $extended);
4075 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
4076 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
4077 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
4078 || ($last =~ /^[{\[\w_]/ &&
4079 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
4081 return $first . $last;
4082 } elsif ($type eq "uc") {
4083 return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
4084 } elsif ($type eq "lc") {
4085 return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
4086 } elsif ($type eq "ucfirst") {
4087 return '\u' . $self->re_dq($op->first->sibling, $extended);
4088 } elsif ($type eq "lcfirst") {
4089 return '\l' . $self->re_dq($op->first->sibling, $extended);
4090 } elsif ($type eq "quotemeta") {
4091 return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
4092 } elsif ($type eq "join") {
4093 return $self->deparse($op->last, 26); # was join($", @ary)
4095 return $self->deparse($op, 26);
4100 my ($self, $op) = @_;
4101 return 0 if null $op;
4102 my $type = $op->name;
4104 if ($type eq 'const') {
4107 elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
4108 return $self->pure_string($op->first->sibling);
4110 elsif ($type eq 'join') {
4111 my $join_op = $op->first->sibling; # Skip pushmark
4112 return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
4114 my $gvop = $join_op->first;
4115 return 0 unless $gvop->name eq 'gvsv';
4116 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
4118 return 0 unless ${$join_op->sibling} eq ${$op->last};
4119 return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
4121 elsif ($type eq 'concat') {
4122 return $self->pure_string($op->first)
4123 && $self->pure_string($op->last);
4125 elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
4128 elsif ($type eq "null" and $op->can('first') and not null $op->first and
4129 $op->first->name eq "null" and $op->first->can('first')
4130 and not null $op->first->first and
4131 $op->first->first->name eq "aelemfast") {
4143 my($op, $cx, $extended) = @_;
4144 my $kid = $op->first;
4145 $kid = $kid->first if $kid->name eq "regcmaybe";
4146 $kid = $kid->first if $kid->name eq "regcreset";
4147 if ($kid->name eq "null" and !null($kid->first)
4148 and $kid->first->name eq 'pushmark')
4151 $kid = $kid->first->sibling;
4152 while (!null($kid)) {
4153 $str .= $self->re_dq($kid, $extended);
4154 $kid = $kid->sibling;
4159 return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
4160 return ($self->deparse($kid, $cx), 0);
4164 my ($self, $op, $cx) = @_;
4165 return (($self->regcomp($op, $cx, 0))[0]);
4168 # osmic acid -- see osmium tetroxide
4171 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
4172 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
4173 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
4177 my($op, $cx, $name, $delim) = @_;
4178 my $kid = $op->first;
4179 my ($binop, $var, $re) = ("", "", "");
4180 if ($op->flags & OPf_STACKED) {
4182 $var = $self->deparse($kid, 20);
4183 $kid = $kid->sibling;
4186 my $extended = ($op->pmflags & PMf_EXTENDED);
4188 my $unbacked = re_unback($op->precomp);
4190 $re = re_uninterp_extended(escape_extended_re($unbacked));
4192 $re = re_uninterp(escape_str(re_unback($op->precomp)));
4194 } elsif ($kid->name ne 'regcomp') {
4195 carp("found ".$kid->name." where regcomp expected");
4197 ($re, $quote) = $self->regcomp($kid, 21, $extended);
4200 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
4201 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
4202 $flags .= "i" if $op->pmflags & PMf_FOLD;
4203 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
4204 $flags .= "o" if $op->pmflags & PMf_KEEP;
4205 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
4206 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
4207 $flags = $matchwords{$flags} if $matchwords{$flags};
4208 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
4212 $re = single_delim($name, $delim, $re);
4214 $re = $re . $flags if $quote;
4216 return $self->maybe_parens("$var =~ $re", $cx, 20);
4222 sub pp_match { matchop(@_, "m", "/") }
4223 sub pp_pushre { matchop(@_, "m", "/") }
4224 sub pp_qr { matchop(@_, "qr", "") }
4229 my($kid, @exprs, $ary, $expr);
4232 # For our kid (an OP_PUSHRE), pmreplroot is never actually the
4233 # root of a replacement; it's either empty, or abused to point to
4234 # the GV for an array we split into (an optimization to save
4235 # assignment overhead). Depending on whether we're using ithreads,
4236 # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
4237 # figures out for us which it is.
4238 my $replroot = $kid->pmreplroot;
4240 if (ref($replroot) eq "B::GV") {
4242 } elsif (!ref($replroot) and $replroot > 0) {
4243 $gv = $self->padval($replroot);
4245 $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
4247 for (; !null($kid); $kid = $kid->sibling) {
4248 push @exprs, $self->deparse($kid, 6);
4251 # handle special case of split(), and split(' ') that compiles to /\s+/
4253 if ( $kid->flags & OPf_SPECIAL
4254 and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
4255 : $kid->reflags & RXf_SKIPWHITE() ) ) {
4259 $expr = "split(" . join(", ", @exprs) . ")";
4261 return $self->maybe_parens("$ary = $expr", $cx, 7);
4267 # oxime -- any of various compounds obtained chiefly by the action of
4268 # hydroxylamine on aldehydes and ketones and characterized by the
4269 # bivalent grouping C=NOH [Webster's Tenth]
4272 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
4273 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
4274 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
4275 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
4280 my $kid = $op->first;
4281 my($binop, $var, $re, $repl) = ("", "", "", "");
4282 if ($op->flags & OPf_STACKED) {
4284 $var = $self->deparse($kid, 20);
4285 $kid = $kid->sibling;
4288 if (null($op->pmreplroot)) {
4289 $repl = $self->dq($kid);
4290 $kid = $kid->sibling;
4292 $repl = $op->pmreplroot->first; # skip substcont
4293 while ($repl->name eq "entereval") {
4294 $repl = $repl->first;
4297 if ($op->pmflags & PMf_EVAL) {
4298 $repl = $self->deparse($repl->first, 0);
4300 $repl = $self->dq($repl);
4303 my $extended = ($op->pmflags & PMf_EXTENDED);
4305 my $unbacked = re_unback($op->precomp);
4307 $re = re_uninterp_extended(escape_extended_re($unbacked));
4310 $re = re_uninterp(escape_str($unbacked));
4313 ($re) = $self->regcomp($kid, 1, $extended);
4315 $flags .= "e" if $op->pmflags & PMf_EVAL;
4316 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
4317 $flags .= "i" if $op->pmflags & PMf_FOLD;
4318 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
4319 $flags .= "o" if $op->pmflags & PMf_KEEP;
4320 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
4321 $flags .= "x" if $extended;
4322 $flags = $substwords{$flags} if $substwords{$flags};
4324 return $self->maybe_parens("$var =~ s"
4325 . double_delim($re, $repl) . $flags,
4328 return "s". double_delim($re, $repl) . $flags;
4337 B::Deparse - Perl compiler backend to produce perl code
4341 B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
4342 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
4346 B::Deparse is a backend module for the Perl compiler that generates
4347 perl source code, based on the internal compiled structure that perl
4348 itself creates after parsing a program. The output of B::Deparse won't
4349 be exactly the same as the original source, since perl doesn't keep
4350 track of comments or whitespace, and there isn't a one-to-one
4351 correspondence between perl's syntactical constructions and their
4352 compiled form, but it will often be close. When you use the B<-p>
4353 option, the output also includes parentheses even when they are not
4354 required by precedence, which can make it easy to see if perl is
4355 parsing your expressions the way you intended.
4357 While B::Deparse goes to some lengths to try to figure out what your
4358 original program was doing, some parts of the language can still trip
4359 it up; it still fails even on some parts of Perl's own test suite. If
4360 you encounter a failure other than the most common ones described in
4361 the BUGS section below, you can help contribute to B::Deparse's
4362 ongoing development by submitting a bug report with a small
4367 As with all compiler backend options, these must follow directly after
4368 the '-MO=Deparse', separated by a comma but not any white space.
4374 Output data values (when they appear as constants) using Data::Dumper.
4375 Without this option, B::Deparse will use some simple routines of its
4376 own for the same purpose. Currently, Data::Dumper is better for some
4377 kinds of data (such as complex structures with sharing and
4378 self-reference) while the built-in routines are better for others
4379 (such as odd floating-point values).
4383 Normally, B::Deparse deparses the main code of a program, and all the subs
4384 defined in the same file. To include subs defined in other files, pass the
4385 B<-f> option with the filename. You can pass the B<-f> option several times, to
4386 include more than one secondary file. (Most of the time you don't want to
4387 use it at all.) You can also use this option to include subs which are
4388 defined in the scope of a B<#line> directive with two parameters.
4392 Add '#line' declarations to the output based on the line and file
4393 locations of the original code.
4397 Print extra parentheses. Without this option, B::Deparse includes
4398 parentheses in its output only when they are needed, based on the
4399 structure of your program. With B<-p>, it uses parentheses (almost)
4400 whenever they would be legal. This can be useful if you are used to
4401 LISP, or if you want to see how perl parses your input. If you say
4403 if ($var & 0x7f == 65) {print "Gimme an A!"}
4404 print ($which ? $a : $b), "\n";
4405 $name = $ENV{USER} or "Bob";
4407 C<B::Deparse,-p> will print
4410 print('Gimme an A!')
4412 (print(($which ? $a : $b)), '???');
4413 (($name = $ENV{'USER'}) or '???')
4415 which probably isn't what you intended (the C<'???'> is a sign that
4416 perl optimized away a constant value).
4420 Disable prototype checking. With this option, all function calls are
4421 deparsed as if no prototype was defined for them. In other words,
4423 perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
4432 making clear how the parameters are actually passed to C<foo>.
4436 Expand double-quoted strings into the corresponding combinations of
4437 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
4440 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
4444 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
4445 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
4447 Note that the expanded form represents the way perl handles such
4448 constructions internally -- this option actually turns off the reverse
4449 translation that B::Deparse usually does. On the other hand, note that
4450 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
4451 of $y into a string before doing the assignment.
4453 =item B<-s>I<LETTERS>
4455 Tweak the style of B::Deparse's output. The letters should follow
4456 directly after the 's', with no space or punctuation. The following
4457 options are available:
4463 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
4480 The default is not to cuddle.
4484 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
4488 Use tabs for each 8 columns of indent. The default is to use only spaces.
4489 For instance, if the style options are B<-si4T>, a line that's indented
4490 3 times will be preceded by one tab and four spaces; if the options were
4491 B<-si8T>, the same line would be preceded by three tabs.
4493 =item B<v>I<STRING>B<.>
4495 Print I<STRING> for the value of a constant that can't be determined
4496 because it was optimized away (mnemonic: this happens when a constant
4497 is used in B<v>oid context). The end of the string is marked by a period.
4498 The string should be a valid perl expression, generally a constant.
4499 Note that unless it's a number, it probably needs to be quoted, and on
4500 a command line quotes need to be protected from the shell. Some
4501 conventional values include 0, 1, 42, '', 'foo', and
4502 'Useless use of constant omitted' (which may need to be
4503 B<-sv"'Useless use of constant omitted'.">
4504 or something similar depending on your shell). The default is '???'.
4505 If you're using B::Deparse on a module or other file that's require'd,
4506 you shouldn't use a value that evaluates to false, since the customary
4507 true constant at the end of a module will be in void context when the
4508 file is compiled as a main program.
4514 Expand conventional syntax constructions into equivalent ones that expose
4515 their internal operation. I<LEVEL> should be a digit, with higher values
4516 meaning more expansion. As with B<-q>, this actually involves turning off
4517 special cases in B::Deparse's normal operations.
4519 If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
4520 while loops with continue blocks; for instance
4522 for ($i = 0; $i < 10; ++$i) {
4535 Note that in a few cases this translation can't be perfectly carried back
4536 into the source code -- if the loop's initializer declares a my variable,
4537 for instance, it won't have the correct scope outside of the loop.
4539 If I<LEVEL> is at least 5, C<use> declarations will be translated into
4540 C<BEGIN> blocks containing calls to C<require> and C<import>; for
4550 'strict'->import('refs')
4554 If I<LEVEL> is at least 7, C<if> statements will be translated into
4555 equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
4557 print 'hi' if $nice;
4569 $nice and print 'hi';
4570 $nice and do { print 'hi' };
4571 $nice ? do { print 'hi' } : do { print 'bye' };
4573 Long sequences of elsifs will turn into nested ternary operators, which
4574 B::Deparse doesn't know how to indent nicely.
4578 =head1 USING B::Deparse AS A MODULE
4583 $deparse = B::Deparse->new("-p", "-sC");
4584 $body = $deparse->coderef2text(\&func);
4585 eval "sub func $body"; # the inverse operation
4589 B::Deparse can also be used on a sub-by-sub basis from other perl
4594 $deparse = B::Deparse->new(OPTIONS)
4596 Create an object to store the state of a deparsing operation and any
4597 options. The options are the same as those that can be given on the
4598 command line (see L</OPTIONS>); options that are separated by commas
4599 after B<-MO=Deparse> should be given as separate strings. Some
4600 options, like B<-u>, don't make sense for a single subroutine, so
4603 =head2 ambient_pragmas
4605 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
4607 The compilation of a subroutine can be affected by a few compiler
4608 directives, B<pragmas>. These are:
4622 Assigning to the special variable $[
4642 Ordinarily, if you use B::Deparse on a subroutine which has
4643 been compiled in the presence of one or more of these pragmas,
4644 the output will include statements to turn on the appropriate
4645 directives. So if you then compile the code returned by coderef2text,
4646 it will behave the same way as the subroutine which you deparsed.
4648 However, you may know that you intend to use the results in a
4649 particular context, where some pragmas are already in scope. In
4650 this case, you use the B<ambient_pragmas> method to describe the
4651 assumptions you wish to make.
4653 Not all of the options currently have any useful effect. See
4654 L</BUGS> for more details.
4656 The parameters it accepts are:
4662 Takes a string, possibly containing several values separated
4663 by whitespace. The special values "all" and "none" mean what you'd
4666 $deparse->ambient_pragmas(strict => 'subs refs');
4670 Takes a number, the value of the array base $[.
4678 If the value is true, then the appropriate pragma is assumed to
4679 be in the ambient scope, otherwise not.
4683 Takes a string, possibly containing a whitespace-separated list of
4684 values. The values "all" and "none" are special. It's also permissible
4685 to pass an array reference here.
4687 $deparser->ambient_pragmas(re => 'eval');
4692 Takes a string, possibly containing a whitespace-separated list of
4693 values. The values "all" and "none" are special, again. It's also
4694 permissible to pass an array reference here.
4696 $deparser->ambient_pragmas(warnings => [qw[void io]]);
4698 If one of the values is the string "FATAL", then all the warnings
4699 in that list will be considered fatal, just as with the B<warnings>
4700 pragma itself. Should you need to specify that some warnings are
4701 fatal, and others are merely enabled, you can pass the B<warnings>
4704 $deparser->ambient_pragmas(
4706 warnings => [FATAL => qw/void io/],
4709 See L<perllexwarn> for more information about lexical warnings.
4715 These two parameters are used to specify the ambient pragmas in
4716 the format used by the special variables $^H and ${^WARNING_BITS}.
4718 They exist principally so that you can write code like:
4720 { my ($hint_bits, $warning_bits);
4721 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
4722 $deparser->ambient_pragmas (
4723 hint_bits => $hint_bits,
4724 warning_bits => $warning_bits,
4728 which specifies that the ambient pragmas are exactly those which
4729 are in scope at the point of calling.
4733 This parameter is used to specify the ambient pragmas which are
4734 stored in the special hash %^H.
4740 $body = $deparse->coderef2text(\&func)
4741 $body = $deparse->coderef2text(sub ($$) { ... })
4743 Return source code for the body of a subroutine (a block, optionally
4744 preceded by a prototype in parens), given a reference to the
4745 sub. Because a subroutine can have no names, or more than one name,
4746 this method doesn't return a complete subroutine definition -- if you
4747 want to eval the result, you should prepend "sub subname ", or "sub "
4748 for an anonymous function constructor. Unless the sub was defined in
4749 the main:: package, the code will include a package declaration.
4757 The only pragmas to be completely supported are: C<use warnings>,
4758 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
4759 behaves like a pragma, is also supported.)
4761 Excepting those listed above, we're currently unable to guarantee that
4762 B::Deparse will produce a pragma at the correct point in the program.
4763 (Specifically, pragmas at the beginning of a block often appear right
4764 before the start of the block instead.)
4765 Since the effects of pragmas are often lexically scoped, this can mean
4766 that the pragma holds sway over a different portion of the program
4767 than in the input file.
4771 In fact, the above is a specific instance of a more general problem:
4772 we can't guarantee to produce BEGIN blocks or C<use> declarations in
4773 exactly the right place. So if you use a module which affects compilation
4774 (such as by over-riding keywords, overloading constants or whatever)
4775 then the output code might not work as intended.
4777 This is the most serious outstanding problem, and will require some help
4778 from the Perl core to fix.
4782 If a keyword is over-ridden, and your program explicitly calls
4783 the built-in version by using CORE::keyword, the output of B::Deparse
4784 will not reflect this. If you run the resulting code, it will call
4785 the over-ridden version rather than the built-in one. (Maybe there
4786 should be an option to B<always> print keyword calls as C<CORE::name>.)
4790 Some constants don't print correctly either with or without B<-d>.
4791 For instance, neither B::Deparse nor Data::Dumper know how to print
4792 dual-valued scalars correctly, as in:
4794 use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
4798 An input file that uses source filtering probably won't be deparsed into
4799 runnable code, because it will still include the B<use> declaration
4800 for the source filtering module, even though the code that is
4801 produced is already ordinary Perl which shouldn't be filtered again.
4805 Optimised away statements are rendered as '???'. This includes statements that
4806 have a compile-time side-effect, such as the obscure
4810 which is not, consequently, deparsed correctly.
4814 Lexical (my) variables declared in scopes external to a subroutine
4815 appear in code2ref output text as package variables. This is a tricky
4816 problem, as perl has no native facility for refering to a lexical variable
4817 defined within a different scope, although L<PadWalker> is a good start.
4821 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4827 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
4828 by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
4829 Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
4830 Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael