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 CVf_ASSERTION
21 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
22 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
25 use vars qw/$AUTOLOAD/;
28 # Changes between 0.50 and 0.51:
29 # - fixed nulled leave with live enter in sort { }
30 # - fixed reference constants (\"str")
31 # - handle empty programs gracefully
32 # - handle infinte loops (for (;;) {}, while (1) {})
33 # - differentiate between `for my $x ...' and `my $x; for $x ...'
34 # - various minor cleanups
35 # - moved globals into an object
36 # - added `-u', like B::C
37 # - package declarations using cop_stash
38 # - subs, formats and code sorted by cop_seq
39 # Changes between 0.51 and 0.52:
40 # - added pp_threadsv (special variables under USE_5005THREADS)
41 # - added documentation
42 # Changes between 0.52 and 0.53:
43 # - many changes adding precedence contexts and associativity
44 # - added `-p' and `-s' output style options
45 # - various other minor fixes
46 # Changes between 0.53 and 0.54:
47 # - added support for new `for (1..100)' optimization,
49 # Changes between 0.54 and 0.55:
50 # - added support for new qr// construct
51 # - added support for new pp_regcreset OP
52 # Changes between 0.55 and 0.56:
53 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
54 # - fixed $# on non-lexicals broken in last big rewrite
55 # - added temporary fix for change in opcode of OP_STRINGIFY
56 # - fixed problem in 0.54's for() patch in `for (@ary)'
57 # - fixed precedence in conditional of ?:
58 # - tweaked list paren elimination in `my($x) = @_'
59 # - made continue-block detection trickier wrt. null ops
60 # - fixed various prototype problems in pp_entersub
61 # - added support for sub prototypes that never get GVs
62 # - added unquoting for special filehandle first arg in truncate
63 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
64 # - added semicolons at the ends of blocks
65 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
66 # Changes between 0.56 and 0.561:
67 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
68 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
69 # Changes between 0.561 and 0.57:
70 # - stylistic changes to symbolic constant stuff
71 # - handled scope in s///e replacement code
72 # - added unquote option for expanding "" into concats, etc.
73 # - split method and proto parts of pp_entersub into separate functions
74 # - various minor cleanups
76 # - added parens in \&foo (patch by Albert Dvornik)
77 # Changes between 0.57 and 0.58:
78 # - fixed `0' statements that weren't being printed
79 # - added methods for use from other programs
80 # (based on patches from James Duncan and Hugo van der Sanden)
81 # - added -si and -sT to control indenting (also based on a patch from Hugo)
82 # - added -sv to print something else instead of '???'
83 # - preliminary version of utf8 tr/// handling
85 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
86 # - added support for Hugo's new OP_SETSTATE (like nextstate)
87 # Changes between 0.58 and 0.59
88 # - added support for Chip's OP_METHOD_NAMED
89 # - added support for Ilya's OPpTARGET_MY optimization
90 # - elided arrows before `()' subscripts when possible
91 # Changes between 0.59 and 0.60
92 # - support for method attribues was added
93 # - some warnings fixed
94 # - separate recognition of constant subs
95 # - rewrote continue block handling, now recoginizing for loops
96 # - added more control of expanding control structures
97 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
99 # - support for pragmas and 'use'
100 # - support for the little-used $[ variable
101 # - support for __DATA__ sections
103 # - BEGIN, CHECK, INIT and END blocks
104 # - scoping of subroutine declarations fixed
105 # - compile-time output from the input program can be suppressed, so that the
106 # output is just the deparsed code. (a change to O.pm in fact)
107 # - our() declarations
108 # - *all* the known bugs are now listed in the BUGS section
109 # - comprehensive test mechanism (TEST -deparse)
110 # Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
113 # - support for command-line switches (-l, -0, etc.)
114 # Changes between 0.63 and 0.64
115 # - support for //, CHECK blocks, and assertions
116 # - improved handling of foreach loops and lexicals
117 # - option to use Data::Dumper for constants
119 # - discovered lots more bugs not yet fixed
123 # Changes between 0.72 and 0.73
124 # - support new switch constructs
127 # (See also BUGS section at the end of this file)
129 # - finish tr/// changes
130 # - add option for even more parens (generalize \&foo change)
131 # - left/right context
132 # - copy comments (look at real text with $^P?)
133 # - avoid semis in one-statement blocks
134 # - associativity of &&=, ||=, ?:
135 # - ',' => '=>' (auto-unquote?)
136 # - break long lines ("\r" as discretionary break?)
137 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
138 # - more style options: brace style, hex vs. octal, quotes, ...
139 # - print big ints as hex/octal instead of decimal (heuristic?)
140 # - handle `my $x if 0'?
141 # - version using op_next instead of op_first/sibling?
142 # - avoid string copies (pass arrays, one big join?)
145 # Current test.deparse failures
146 # comp/assertions 38 - disabled assertions should be like "my($x) if 0"
147 # 'sub f : assertion {}; no assertions; my $x=1; {f(my $x=2); print "$x\n"}'
148 # comp/hints 6 - location of BEGIN blocks wrt. block openings
149 # run/switchI 1 - missing -I switches entirely
150 # perl -Ifoo -e 'print @INC'
151 # op/caller 2 - warning mask propagates backwards before warnings::register
152 # 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
153 # op/getpid 2 - can't assign to shared my() declaration (threads only)
154 # 'my $x : shared = 5'
155 # op/override 7 - parens on overriden require change v-string interpretation
156 # 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
157 # c.f. 'BEGIN { *f = sub {0} }; f 2'
158 # op/pat 774 - losing Unicode-ness of Latin1-only strings
159 # 'use charnames ":short"; $x="\N{latin:a with acute}"'
160 # op/recurse 12 - missing parens on recursive call makes it look like method
162 # op/subst 90 - inconsistent handling of utf8 under "use utf8"
163 # op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
164 # op/tiehandle compile - "use strict" deparsed in the wrong place
166 # ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
167 # ext/Data/Dumper/t/dumper compile
168 # ext/DB_file/several
170 # ext/Ernno/Errno warnings
171 # ext/IO/lib/IO/t/io_sel 23
172 # ext/PerlIO/t/encoding compile
173 # ext/POSIX/t/posix 6
174 # ext/Socket/Socket 8
175 # ext/Storable/t/croak compile
176 # lib/Attribute/Handlers/t/multi compile
177 # lib/bignum/ several
181 # lib/ExtUtils/t/bytes 4
182 # lib/File/DosGlob compile
183 # lib/Filter/Simple/t/data 1
184 # lib/Math/BigInt/t/constant 1
185 # lib/Net/t/config Deparse-warning
186 # lib/overload compile
187 # lib/Switch/ several
189 # lib/Test/Simple several
191 # lib/Tie/File/t/29_downcopy 5
194 # Object fields (were globals):
197 # (local($a), local($b)) and local($a, $b) have the same internal
198 # representation but the short form looks better. We notice we can
199 # use a large-scale local when checking the list, but need to prevent
200 # individual locals too. This hash holds the addresses of OPs that
201 # have already had their local-ness accounted for. The same thing
205 # CV for current sub (or main program) being deparsed
208 # Cached hash of lexical variables for curcv: keys are names,
209 # each value is an array of pairs, indicating the cop_seq of scopes
210 # in which a var of that name is valid.
213 # COP for statement being deparsed
216 # name of the current package for deparsed code
219 # array of [cop_seq, CV, is_format?] for subs and formats we still
223 # as above, but [name, prototype] for subs that never got a GV
225 # subs_done, forms_done:
226 # keys are addresses of GVs for subs and formats we've already
227 # deparsed (or at least put into subs_todo)
230 # keys are names of subs for which we've printed declarations.
231 # That means we can omit parentheses from the arguments.
234 # Keeps track of fully qualified names of all deparsed subs.
239 # cuddle: ` ' or `\n', depending on -sC
244 # A little explanation of how precedence contexts and associativity
247 # deparse() calls each per-op subroutine with an argument $cx (short
248 # for context, but not the same as the cx* in the perl core), which is
249 # a number describing the op's parents in terms of precedence, whether
250 # they're inside an expression or at statement level, etc. (see
251 # chart below). When ops with children call deparse on them, they pass
252 # along their precedence. Fractional values are used to implement
253 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
254 # parentheses hacks. The major disadvantage of this scheme is that
255 # it doesn't know about right sides and left sides, so say if you
256 # assign a listop to a variable, it can't tell it's allowed to leave
257 # the parens off the listop.
260 # 26 [TODO] inside interpolation context ("")
261 # 25 left terms and list operators (leftward)
265 # 21 right ! ~ \ and unary + and -
270 # 16 nonassoc named unary operators
271 # 15 nonassoc < > <= >= lt gt le ge
272 # 14 nonassoc == != <=> eq ne cmp
279 # 7 right = += -= *= etc.
281 # 5 nonassoc list operators (rightward)
285 # 1 statement modifiers
286 # 0.5 statements, but still print scopes as do { ... }
289 # Nonprinting characters with special meaning:
290 # \cS - steal parens (see maybe_parens_unop)
291 # \n - newline and indent
292 # \t - increase indent
293 # \b - decrease indent (`outdent')
294 # \f - flush left (no indent)
295 # \cK - kill following semicolon, if any
299 return class($op) eq "NULL";
304 my($cv, $is_form) = @_;
305 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
307 if ($cv->OUTSIDE_SEQ) {
308 $seq = $cv->OUTSIDE_SEQ;
309 } elsif (!null($cv->START) and is_state($cv->START)) {
310 $seq = $cv->START->cop_seq;
314 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
315 unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
316 $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
322 my $ent = shift @{$self->{'subs_todo'}};
325 my $name = $self->gv_name($gv);
327 return "format $name =\n"
328 . $self->deparse_format($ent->[1]). "\n";
330 $self->{'subs_declared'}{$name} = 1;
331 if ($name eq "BEGIN") {
332 my $use_dec = $self->begin_is_use($cv);
333 if (defined ($use_dec) and $self->{'expand'} < 5) {
334 return () if 0 == length($use_dec);
339 if ($self->{'linenums'}) {
340 my $line = $gv->LINE;
341 my $file = $gv->FILE;
342 $l = "\n\f#line $line \"$file\"\n";
345 if (class($cv->STASH) ne "SPECIAL") {
346 my $stash = $cv->STASH->NAME;
347 if ($stash ne $self->{'curstash'}) {
348 $p = "package $stash;\n";
349 $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
350 $self->{'curstash'} = $stash;
352 $name =~ s/^\Q$stash\E:://;
354 return "${p}${l}sub $name " . $self->deparse_sub($cv);
358 # Return a "use" declaration for this BEGIN block, if appropriate
360 my ($self, $cv) = @_;
361 my $root = $cv->ROOT;
362 local @$self{qw'curcv curcvlex'} = ($cv);
364 #B::walkoptree($cv->ROOT, "debug");
365 my $lineseq = $root->first;
366 return if $lineseq->name ne "lineseq";
368 my $req_op = $lineseq->first->sibling;
369 return if $req_op->name ne "require";
372 if ($req_op->first->private & OPpCONST_BARE) {
373 # Actually it should always be a bareword
374 $module = $self->const_sv($req_op->first)->PV;
375 $module =~ s[/][::]g;
379 $module = $self->const($self->const_sv($req_op->first), 6);
383 my $version_op = $req_op->sibling;
384 return if class($version_op) eq "NULL";
385 if ($version_op->name eq "lineseq") {
386 # We have a version parameter; skip nextstate & pushmark
387 my $constop = $version_op->first->next->next;
389 return unless $self->const_sv($constop)->PV eq $module;
390 $constop = $constop->sibling;
391 $version = $self->const_sv($constop);
392 if (class($version) eq "IV") {
393 $version = $version->int_value;
394 } elsif (class($version) eq "NV") {
395 $version = $version->NV;
396 } elsif (class($version) ne "PVMG") {
397 # Includes PVIV and PVNV
398 $version = $version->PV;
400 # version specified as a v-string
401 $version = 'v'.join '.', map ord, split //, $version->PV;
403 $constop = $constop->sibling;
404 return if $constop->name ne "method_named";
405 return if $self->const_sv($constop)->PV ne "VERSION";
408 $lineseq = $version_op->sibling;
409 return if $lineseq->name ne "lineseq";
410 my $entersub = $lineseq->first->sibling;
411 if ($entersub->name eq "stub") {
412 return "use $module $version ();\n" if defined $version;
413 return "use $module ();\n";
415 return if $entersub->name ne "entersub";
417 # See if there are import arguments
420 my $svop = $entersub->first->sibling; # Skip over pushmark
421 return unless $self->const_sv($svop)->PV eq $module;
423 # Pull out the arguments
424 for ($svop=$svop->sibling; $svop->name ne "method_named";
425 $svop = $svop->sibling) {
426 $args .= ", " if length($args);
427 $args .= $self->deparse($svop, 6);
431 my $method_named = $svop;
432 return if $method_named->name ne "method_named";
433 my $method_name = $self->const_sv($method_named)->PV;
435 if ($method_name eq "unimport") {
439 # Certain pragmas are dealt with using hint bits,
440 # so we ignore them here
441 if ($module eq 'strict' || $module eq 'integer'
442 || $module eq 'bytes' || $module eq 'warnings') {
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 next if $key eq 'main::'; # avoid infinite recursion
472 my $class = class($val);
473 if ($class eq "PV") {
474 # Just a prototype. As an ugly but fairly effective way
475 # to find out if it belongs here is to see if the AUTOLOAD
476 # (if any) for the stash was defined in one of our files.
477 my $A = $stash{"AUTOLOAD"};
478 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
479 && class($A->CV) eq "CV") {
481 next unless $AF eq $0 || exists $self->{'files'}{$AF};
483 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
484 } elsif ($class eq "IV") {
485 # Just a name. As above.
486 my $A = $stash{"AUTOLOAD"};
487 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
488 && class($A->CV) eq "CV") {
490 next unless $AF eq $0 || exists $self->{'files'}{$AF};
492 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
493 } elsif ($class eq "GV") {
494 if (class(my $cv = $val->CV) ne "SPECIAL") {
495 next if $self->{'subs_done'}{$$val}++;
496 next if $$val != ${$cv->GV}; # Ignore imposters
499 if (class(my $cv = $val->FORM) ne "SPECIAL") {
500 next if $self->{'forms_done'}{$$val}++;
501 next if $$val != ${$cv->GV}; # Ignore imposters
504 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
505 $self->stash_subs($pack . $key);
515 foreach $ar (@{$self->{'protos_todo'}}) {
516 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
517 push @ret, "sub " . $ar->[0] . "$proto;\n";
519 delete $self->{'protos_todo'};
527 while (length($opt = substr($opts, 0, 1))) {
529 $self->{'cuddle'} = " ";
530 $opts = substr($opts, 1);
531 } elsif ($opt eq "i") {
532 $opts =~ s/^i(\d+)//;
533 $self->{'indent_size'} = $1;
534 } elsif ($opt eq "T") {
535 $self->{'use_tabs'} = 1;
536 $opts = substr($opts, 1);
537 } elsif ($opt eq "v") {
538 $opts =~ s/^v([^.]*)(.|$)//;
539 $self->{'ex_const'} = $1;
546 my $self = bless {}, $class;
547 $self->{'cuddle'} = "\n";
548 $self->{'curcop'} = undef;
549 $self->{'curstash'} = "main";
550 $self->{'ex_const'} = "'???'";
551 $self->{'expand'} = 0;
552 $self->{'files'} = {};
553 $self->{'indent_size'} = 4;
554 $self->{'linenums'} = 0;
555 $self->{'parens'} = 0;
556 $self->{'subs_todo'} = [];
557 $self->{'unquote'} = 0;
558 $self->{'use_dumper'} = 0;
559 $self->{'use_tabs'} = 0;
561 $self->{'ambient_arybase'} = 0;
562 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
563 $self->{'ambient_hints'} = 0;
566 while (my $arg = shift @_) {
568 $self->{'use_dumper'} = 1;
569 require Data::Dumper;
570 } elsif ($arg =~ /^-f(.*)/) {
571 $self->{'files'}{$1} = 1;
572 } elsif ($arg eq "-l") {
573 $self->{'linenums'} = 1;
574 } elsif ($arg eq "-p") {
575 $self->{'parens'} = 1;
576 } elsif ($arg eq "-P") {
577 $self->{'noproto'} = 1;
578 } elsif ($arg eq "-q") {
579 $self->{'unquote'} = 1;
580 } elsif (substr($arg, 0, 2) eq "-s") {
581 $self->style_opts(substr $arg, 2);
582 } elsif ($arg =~ /^-x(\d)$/) {
583 $self->{'expand'} = $1;
590 # Mask out the bits that L<warnings::register> uses
593 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
600 # Initialise the contextual information, either from
601 # defaults provided with the ambient_pragmas method,
602 # or from perl's own defaults otherwise.
606 $self->{'arybase'} = $self->{'ambient_arybase'};
607 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
608 ? $self->{'ambient_warnings'} & WARN_MASK
610 $self->{'hints'} = $self->{'ambient_hints'};
611 $self->{'hints'} &= 0xFF if $] < 5.009;
613 # also a convenient place to clear out subs_declared
614 delete $self->{'subs_declared'};
620 my $self = B::Deparse->new(@args);
621 # First deparse command-line args
622 if (defined $^I) { # deparse -i
623 print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
625 if ($^W) { # deparse -w
626 print qq(BEGIN { \$^W = $^W; }\n);
628 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
629 my $fs = perlstring($/) || 'undef';
630 my $bs = perlstring($O::savebackslash) || 'undef';
631 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
633 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
634 my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
635 ? B::unitcheck_av->ARRAY
637 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
638 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
639 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
640 for my $block (@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
641 $self->todo($block, 0);
644 local($SIG{"__DIE__"}) =
646 if ($self->{'curcop'}) {
647 my $cop = $self->{'curcop'};
648 my($line, $file) = ($cop->line, $cop->file);
649 print STDERR "While deparsing $file near line $line,\n";
652 $self->{'curcv'} = main_cv;
653 $self->{'curcvlex'} = undef;
654 print $self->print_protos;
655 @{$self->{'subs_todo'}} =
656 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
657 print $self->indent($self->deparse_root(main_root)), "\n"
658 unless null main_root;
660 while (scalar(@{$self->{'subs_todo'}})) {
661 push @text, $self->next_todo;
663 print $self->indent(join("", @text)), "\n" if @text;
665 # Print __DATA__ section, if necessary
667 my $laststash = defined $self->{'curcop'}
668 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
669 if (defined *{$laststash."::DATA"}{IO}) {
670 print "package $laststash;\n"
671 unless $laststash eq $self->{'curstash'};
673 print readline(*{$laststash."::DATA"});
681 croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
684 return $self->indent($self->deparse_sub(svref_2object($sub)));
687 sub ambient_pragmas {
689 my ($arybase, $hint_bits, $warning_bits) = (0, 0);
695 if ($name eq 'strict') {
698 if ($val eq 'none') {
699 $hint_bits &= ~strict::bits(qw/refs subs vars/);
705 @names = qw/refs subs vars/;
711 @names = split' ', $val;
713 $hint_bits |= strict::bits(@names);
716 elsif ($name eq '$[') {
720 elsif ($name eq 'integer'
722 || $name eq 'utf8') {
725 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
728 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
732 elsif ($name eq 're') {
734 if ($val eq 'none') {
735 $hint_bits &= ~re::bits(qw/taint eval/);
741 @names = qw/taint eval/;
747 @names = split' ',$val;
749 $hint_bits |= re::bits(@names);
752 elsif ($name eq 'warnings') {
753 if ($val eq 'none') {
754 $warning_bits = $warnings::NONE;
763 @names = split/\s+/, $val;
766 $warning_bits = $warnings::NONE if !defined ($warning_bits);
767 $warning_bits |= warnings::bits(@names);
770 elsif ($name eq 'warning_bits') {
771 $warning_bits = $val;
774 elsif ($name eq 'hint_bits') {
779 croak "Unknown pragma type: $name";
783 croak "The ambient_pragmas method expects an even number of args";
786 $self->{'ambient_arybase'} = $arybase;
787 $self->{'ambient_warnings'} = $warning_bits;
788 $self->{'ambient_hints'} = $hint_bits;
791 # This method is the inner loop, so try to keep it simple
796 Carp::confess("Null op in deparse") if !defined($op)
797 || class($op) eq "NULL";
798 my $meth = "pp_" . $op->name;
799 return $self->$meth($op, $cx);
805 my @lines = split(/\n/, $txt);
810 my $cmd = substr($line, 0, 1);
811 if ($cmd eq "\t" or $cmd eq "\b") {
812 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
813 if ($self->{'use_tabs'}) {
814 $leader = "\t" x ($level / 8) . " " x ($level % 8);
816 $leader = " " x $level;
818 $line = substr($line, 1);
820 if (substr($line, 0, 1) eq "\f") {
821 $line = substr($line, 1); # no indent
823 $line = $leader . $line;
827 return join("\n", @lines);
834 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
835 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
836 local $self->{'curcop'} = $self->{'curcop'};
837 if ($cv->FLAGS & SVf_POK) {
838 $proto = "(". $cv->PV . ") ";
840 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)) {
842 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
843 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
844 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
845 $proto .= "assertion " if $cv->CvFLAGS & CVf_ASSERTION;
848 local($self->{'curcv'}) = $cv;
849 local($self->{'curcvlex'});
850 local(@$self{qw'curstash warnings hints'})
851 = @$self{qw'curstash warnings hints'};
853 if (not null $cv->ROOT) {
854 my $lineseq = $cv->ROOT->first;
855 if ($lineseq->name eq "lineseq") {
857 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
860 $body = $self->lineseq(undef, @ops).";";
861 my $scope_en = $self->find_scope_en($lineseq);
862 if (defined $scope_en) {
863 my $subs = join"", $self->seq_subs($scope_en);
864 $body .= ";\n$subs" if length($subs);
868 $body = $self->deparse($cv->ROOT->first, 0);
872 my $sv = $cv->const_sv;
874 # uh-oh. inlinable sub... format it differently
875 return $proto . "{ " . $self->const($sv, 0) . " }\n";
876 } else { # XSUB? (or just a declaration)
880 return $proto ."{\n\t$body\n\b}" ."\n";
887 local($self->{'curcv'}) = $form;
888 local($self->{'curcvlex'});
889 local($self->{'in_format'}) = 1;
890 local(@$self{qw'curstash warnings hints'})
891 = @$self{qw'curstash warnings hints'};
892 my $op = $form->ROOT;
894 return "\f." if $op->first->name eq 'stub'
895 || $op->first->name eq 'nextstate';
896 $op = $op->first->first; # skip leavewrite, lineseq
897 while (not null $op) {
898 $op = $op->sibling; # skip nextstate
900 $kid = $op->first->sibling; # skip pushmark
901 push @text, "\f".$self->const_sv($kid)->PV;
902 $kid = $kid->sibling;
903 for (; not null $kid; $kid = $kid->sibling) {
904 push @exprs, $self->deparse($kid, 0);
906 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
909 return join("", @text) . "\f.";
914 return $op->name eq "leave" || $op->name eq "scope"
915 || $op->name eq "lineseq"
916 || ($op->name eq "null" && class($op) eq "UNOP"
917 && (is_scope($op->first) || $op->first->name eq "enter"));
921 my $name = $_[0]->name;
922 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
925 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
927 return (!null($op) and null($op->sibling)
928 and $op->name eq "null" and class($op) eq "UNOP"
929 and (($op->first->name =~ /^(and|or)$/
930 and $op->first->first->sibling->name eq "lineseq")
931 or ($op->first->name eq "lineseq"
932 and not null $op->first->first->sibling
933 and $op->first->first->sibling->name eq "unstack")
937 # Check if the op and its sibling are the initialization and the rest of a
938 # for (..;..;..) { ... } loop
941 # This OP might be almost anything, though it won't be a
942 # nextstate. (It's the initialization, so in the canonical case it
943 # will be an sassign.) The sibling is a lineseq whose first child
944 # is a nextstate and whose second is a leaveloop.
945 my $lseq = $op->sibling;
946 if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") {
947 if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
948 && (my $sib = $lseq->first->sibling)) {
949 return (!null($sib) && $sib->name eq "leaveloop");
957 return ($op->name eq "rv2sv" or
958 $op->name eq "padsv" or
959 $op->name eq "gv" or # only in array/hash constructs
960 $op->flags & OPf_KIDS && !null($op->first)
961 && $op->first->name eq "gvsv");
966 my($text, $cx, $prec) = @_;
967 if ($prec < $cx # unary ops nest just fine
968 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
969 or $self->{'parens'})
972 # In a unop, let parent reuse our parens; see maybe_parens_unop
973 $text = "\cS" . $text if $cx == 16;
980 # same as above, but get around the `if it looks like a function' rule
981 sub maybe_parens_unop {
983 my($name, $kid, $cx) = @_;
984 if ($cx > 16 or $self->{'parens'}) {
985 $kid = $self->deparse($kid, 1);
986 if ($name eq "umask" && $kid =~ /^\d+$/) {
987 $kid = sprintf("%#o", $kid);
989 return "$name($kid)";
991 $kid = $self->deparse($kid, 16);
992 if ($name eq "umask" && $kid =~ /^\d+$/) {
993 $kid = sprintf("%#o", $kid);
995 if (substr($kid, 0, 1) eq "\cS") {
997 return $name . substr($kid, 1);
998 } elsif (substr($kid, 0, 1) eq "(") {
999 # avoid looks-like-a-function trap with extra parens
1000 # (`+' can lead to ambiguities)
1001 return "$name(" . $kid . ")";
1003 return "$name $kid";
1008 sub maybe_parens_func {
1010 my($func, $text, $cx, $prec) = @_;
1011 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
1012 return "$func($text)";
1014 return "$func $text";
1020 my($op, $cx, $text) = @_;
1021 my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
1022 if ($op->private & (OPpLVAL_INTRO|$our_intro)
1023 and not $self->{'avoid_local'}{$$op}) {
1024 my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
1025 if( $our_local eq 'our' ) {
1026 # XXX This assertion fails code with non-ASCII identifiers,
1027 # like ./ext/Encode/t/jperl.t
1028 die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
1029 $text =~ s/(\w+::)+//;
1031 if (want_scalar($op)) {
1032 return "$our_local $text";
1034 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
1043 my($op, $cx, $func, @args) = @_;
1044 if ($op->private & OPpTARGET_MY) {
1045 my $var = $self->padname($op->targ);
1046 my $val = $func->($self, $op, 7, @args);
1047 return $self->maybe_parens("$var = $val", $cx, 7);
1049 return $func->($self, $op, $cx, @args);
1056 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
1061 my($op, $cx, $text) = @_;
1062 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
1063 my $my = $op->private & OPpPAD_STATE ? "state" : "my";
1064 if (want_scalar($op)) {
1067 return $self->maybe_parens_func($my, $text, $cx, 16);
1074 # The following OPs don't have functions:
1076 # pp_padany -- does not exist after parsing
1079 if ($AUTOLOAD =~ s/^.*::pp_//) {
1080 warn "unexpected OP_".uc $AUTOLOAD;
1083 die "Undefined subroutine $AUTOLOAD called";
1087 sub DESTROY {} # Do not AUTOLOAD
1089 # $root should be the op which represents the root of whatever
1090 # we're sequencing here. If it's undefined, then we don't append
1091 # any subroutine declarations to the deparsed ops, otherwise we
1092 # append appropriate declarations.
1094 my($self, $root, @ops) = @_;
1097 my $out_cop = $self->{'curcop'};
1098 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1100 if (defined $root) {
1101 $limit_seq = $out_seq;
1103 $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1104 $limit_seq = $nseq if !defined($limit_seq)
1105 or defined($nseq) && $nseq < $limit_seq;
1107 $limit_seq = $self->{'limit_seq'}
1108 if defined($self->{'limit_seq'})
1109 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1110 local $self->{'limit_seq'} = $limit_seq;
1111 for (my $i = 0; $i < @ops; $i++) {
1113 if (is_state $ops[$i]) {
1114 $expr = $self->deparse($ops[$i], 0);
1121 if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and
1122 !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq")
1124 if ($ls->first && !null($ls->first) && is_state($ls->first)
1125 && (my $sib = $ls->first->sibling)) {
1126 if (!null($sib) && $sib->name eq "leaveloop") {
1127 push @exprs, $expr . $self->for_loop($ops[$i], 0);
1133 $expr .= $self->deparse($ops[$i], (@ops != 1)/2);
1134 $expr =~ s/;\n?\z//;
1137 my $body = join(";\n", grep {length} @exprs);
1139 if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1140 $subs = join "\n", $self->seq_subs($limit_seq);
1142 return join(";\n", grep {length} $body, $subs);
1146 my($real_block, $self, $op, $cx) = @_;
1150 local(@$self{qw'curstash warnings hints'})
1151 = @$self{qw'curstash warnings hints'} if $real_block;
1153 $kid = $op->first->sibling; # skip enter
1154 if (is_miniwhile($kid)) {
1155 my $top = $kid->first;
1156 my $name = $top->name;
1157 if ($name eq "and") {
1159 } elsif ($name eq "or") {
1161 } else { # no conditional -> while 1 or until 0
1162 return $self->deparse($top->first, 1) . " while 1";
1164 my $cond = $top->first;
1165 my $body = $cond->sibling->first; # skip lineseq
1166 $cond = $self->deparse($cond, 1);
1167 $body = $self->deparse($body, 1);
1168 return "$body $name $cond";
1173 for (; !null($kid); $kid = $kid->sibling) {
1176 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
1177 return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
1179 my $lineseq = $self->lineseq($op, @kids);
1180 return (length ($lineseq) ? "$lineseq;" : "");
1184 sub pp_scope { scopeop(0, @_); }
1185 sub pp_lineseq { scopeop(0, @_); }
1186 sub pp_leave { scopeop(1, @_); }
1188 # This is a special case of scopeop and lineseq, for the case of the
1189 # main_root. The difference is that we print the output statements as
1190 # soon as we get them, for the sake of impatient users.
1194 local(@$self{qw'curstash warnings hints'})
1195 = @$self{qw'curstash warnings hints'};
1197 return if null $op->first; # Can happen, e.g., for Bytecode without -k
1198 for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
1201 for (my $i = 0; $i < @kids; $i++) {
1203 if (is_state $kids[$i]) {
1204 $expr = $self->deparse($kids[$i], 0);
1207 print $self->indent($expr);
1211 if (is_for_loop($kids[$i])) {
1212 $expr .= $self->for_loop($kids[$i], 0);
1213 $expr .= ";\n" unless $i == $#kids;
1214 print $self->indent($expr);
1218 $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
1219 $expr =~ s/;\n?\z//;
1221 print $self->indent($expr);
1222 print "\n" unless $i == $#kids;
1226 # The BEGIN {} is used here because otherwise this code isn't executed
1227 # when you run B::Deparse on itself.
1229 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1230 "ENV", "ARGV", "ARGVOUT", "_"); }
1235 Carp::confess() unless ref($gv) eq "B::GV";
1236 my $stash = $gv->STASH->NAME;
1237 my $name = $gv->SAFENAME;
1238 if (($stash eq 'main' && $globalnames{$name})
1239 or ($stash eq $self->{'curstash'} && !$globalnames{$name})
1240 or $name =~ /^[^A-Za-z_:]/)
1244 $stash = $stash . "::";
1246 if ($name =~ /^(\^..|{)/) {
1247 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
1249 return $stash . $name;
1252 # Return the name to use for a stash variable.
1253 # If a lexical with the same name is in scope, it may need to be
1255 sub stash_variable {
1256 my ($self, $prefix, $name) = @_;
1258 return "$prefix$name" if $name =~ /::/;
1260 unless ($prefix eq '$' || $prefix eq '@' || #'
1261 $prefix eq '%' || $prefix eq '$#') {
1262 return "$prefix$name";
1265 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1266 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
1267 return "$prefix$name";
1271 my ($self, $name) = @_;
1272 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1274 return 0 if !defined($self->{'curcop'});
1275 my $seq = $self->{'curcop'}->cop_seq;
1276 return 0 if !exists $self->{'curcvlex'}{$name};
1277 for my $a (@{$self->{'curcvlex'}{$name}}) {
1278 my ($st, $en) = @$a;
1279 return 1 if $seq > $st && $seq <= $en;
1284 sub populate_curcvlex {
1286 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1287 my $padlist = $cv->PADLIST;
1288 # an undef CV still in lexical chain
1289 next if class($padlist) eq "SPECIAL";
1290 my @padlist = $padlist->ARRAY;
1291 my @ns = $padlist[0]->ARRAY;
1293 for (my $i=0; $i<@ns; ++$i) {
1294 next if class($ns[$i]) eq "SPECIAL";
1295 next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
1296 if (class($ns[$i]) eq "PV") {
1297 # Probably that pesky lexical @_
1300 my $name = $ns[$i]->PVX;
1301 my ($seq_st, $seq_en) =
1302 ($ns[$i]->FLAGS & SVf_FAKE)
1304 : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
1306 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1311 sub find_scope_st { ((find_scope(@_))[0]); }
1312 sub find_scope_en { ((find_scope(@_))[1]); }
1314 # Recurses down the tree, looking for pad variable introductions and COPs
1316 my ($self, $op, $scope_st, $scope_en) = @_;
1317 carp("Undefined op in find_scope") if !defined $op;
1318 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1321 while(my $op = shift @queue ) {
1322 for (my $o=$op->first; $$o; $o=$o->sibling) {
1323 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1324 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
1325 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
1326 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1327 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1328 return ($scope_st, $scope_en);
1330 elsif (is_state($o)) {
1331 my $c = $o->cop_seq;
1332 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1333 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1334 return ($scope_st, $scope_en);
1336 elsif ($o->flags & OPf_KIDS) {
1337 unshift (@queue, $o);
1342 return ($scope_st, $scope_en);
1345 # Returns a list of subs which should be inserted before the COP
1347 my ($self, $op, $out_seq) = @_;
1348 my $seq = $op->cop_seq;
1349 # If we have nephews, then our sequence number indicates
1350 # the cop_seq of the end of some sort of scope.
1351 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1352 and my $nseq = $self->find_scope_st($op->sibling) ) {
1355 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1356 return $self->seq_subs($seq);
1360 my ($self, $seq) = @_;
1362 #push @text, "# ($seq)\n";
1364 return "" if !defined $seq;
1365 while (scalar(@{$self->{'subs_todo'}})
1366 and $seq > $self->{'subs_todo'}[0][0]) {
1367 push @text, $self->next_todo;
1372 # Notice how subs and formats are inserted between statements here;
1373 # also $[ assignments and pragmas.
1377 $self->{'curcop'} = $op;
1379 push @text, $self->cop_subs($op);
1380 push @text, $op->label . ": " if $op->label;
1381 my $stash = $op->stashpv;
1382 if ($stash ne $self->{'curstash'}) {
1383 push @text, "package $stash;\n";
1384 $self->{'curstash'} = $stash;
1387 if ($self->{'arybase'} != $op->arybase) {
1388 push @text, '$[ = '. $op->arybase .";\n";
1389 $self->{'arybase'} = $op->arybase;
1392 my $warnings = $op->warnings;
1394 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1395 $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
1397 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1398 $warning_bits = $warnings::NONE;
1400 elsif ($warnings->isa("B::SPECIAL")) {
1401 $warning_bits = undef;
1404 $warning_bits = $warnings->PV & WARN_MASK;
1407 if (defined ($warning_bits) and
1408 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1409 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1410 $self->{'warnings'} = $warning_bits;
1413 if ($self->{'hints'} != $op->hints) {
1414 push @text, declare_hints($self->{'hints'}, $op->hints);
1415 $self->{'hints'} = $op->hints;
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";
1457 push @pragmas, "integer" if $bits & 0x1;
1458 push @pragmas, "strict 'refs'" if $bits & 0x2;
1459 push @pragmas, "bytes" if $bits & 0x8;
1463 sub pp_dbstate { pp_nextstate(@_) }
1464 sub pp_setstate { pp_nextstate(@_) }
1466 sub pp_unstack { return "" } # see also leaveloop
1470 my($op, $cx, $name) = @_;
1476 my($op, $cx, $name) = @_;
1484 sub pp_wantarray { baseop(@_, "wantarray") }
1485 sub pp_fork { baseop(@_, "fork") }
1486 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1487 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1488 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1489 sub pp_tms { baseop(@_, "times") }
1490 sub pp_ghostent { baseop(@_, "gethostent") }
1491 sub pp_gnetent { baseop(@_, "getnetent") }
1492 sub pp_gprotoent { baseop(@_, "getprotoent") }
1493 sub pp_gservent { baseop(@_, "getservent") }
1494 sub pp_ehostent { baseop(@_, "endhostent") }
1495 sub pp_enetent { baseop(@_, "endnetent") }
1496 sub pp_eprotoent { baseop(@_, "endprotoent") }
1497 sub pp_eservent { baseop(@_, "endservent") }
1498 sub pp_gpwent { baseop(@_, "getpwent") }
1499 sub pp_spwent { baseop(@_, "setpwent") }
1500 sub pp_epwent { baseop(@_, "endpwent") }
1501 sub pp_ggrent { baseop(@_, "getgrent") }
1502 sub pp_sgrent { baseop(@_, "setgrent") }
1503 sub pp_egrent { baseop(@_, "endgrent") }
1504 sub pp_getlogin { baseop(@_, "getlogin") }
1506 sub POSTFIX () { 1 }
1508 # I couldn't think of a good short name, but this is the category of
1509 # symbolic unary operators with interesting precedence
1513 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1514 my $kid = $op->first;
1515 $kid = $self->deparse($kid, $prec);
1516 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1520 sub pp_preinc { pfixop(@_, "++", 23) }
1521 sub pp_predec { pfixop(@_, "--", 23) }
1522 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1523 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1524 sub pp_i_preinc { pfixop(@_, "++", 23) }
1525 sub pp_i_predec { pfixop(@_, "--", 23) }
1526 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1527 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1528 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1530 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1534 if ($op->first->name =~ /^(i_)?negate$/) {
1536 $self->pfixop($op, $cx, "-", 21.5);
1538 $self->pfixop($op, $cx, "-", 21);
1541 sub pp_i_negate { pp_negate(@_) }
1547 $self->pfixop($op, $cx, "not ", 4);
1549 $self->pfixop($op, $cx, "!", 21);
1555 my($op, $cx, $name) = @_;
1557 if ($op->flags & OPf_KIDS) {
1559 if (defined prototype("CORE::$name")
1560 && prototype("CORE::$name") =~ /^;?\*/
1561 && $kid->name eq "rv2gv") {
1565 return $self->maybe_parens_unop($name, $kid, $cx);
1567 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1571 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1572 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1573 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1574 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1575 sub pp_defined { unop(@_, "defined") }
1576 sub pp_undef { unop(@_, "undef") }
1577 sub pp_study { unop(@_, "study") }
1578 sub pp_ref { unop(@_, "ref") }
1579 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1581 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1582 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1583 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1584 sub pp_srand { unop(@_, "srand") }
1585 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1586 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1587 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1588 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1589 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1590 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1591 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1593 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1594 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1595 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1597 sub pp_each { unop(@_, "each") }
1598 sub pp_values { unop(@_, "values") }
1599 sub pp_keys { unop(@_, "keys") }
1600 sub pp_pop { unop(@_, "pop") }
1601 sub pp_shift { unop(@_, "shift") }
1603 sub pp_caller { unop(@_, "caller") }
1604 sub pp_reset { unop(@_, "reset") }
1605 sub pp_exit { unop(@_, "exit") }
1606 sub pp_prototype { unop(@_, "prototype") }
1608 sub pp_close { unop(@_, "close") }
1609 sub pp_fileno { unop(@_, "fileno") }
1610 sub pp_umask { unop(@_, "umask") }
1611 sub pp_untie { unop(@_, "untie") }
1612 sub pp_tied { unop(@_, "tied") }
1613 sub pp_dbmclose { unop(@_, "dbmclose") }
1614 sub pp_getc { unop(@_, "getc") }
1615 sub pp_eof { unop(@_, "eof") }
1616 sub pp_tell { unop(@_, "tell") }
1617 sub pp_getsockname { unop(@_, "getsockname") }
1618 sub pp_getpeername { unop(@_, "getpeername") }
1620 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1621 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1622 sub pp_readlink { unop(@_, "readlink") }
1623 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1624 sub pp_readdir { unop(@_, "readdir") }
1625 sub pp_telldir { unop(@_, "telldir") }
1626 sub pp_rewinddir { unop(@_, "rewinddir") }
1627 sub pp_closedir { unop(@_, "closedir") }
1628 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1629 sub pp_localtime { unop(@_, "localtime") }
1630 sub pp_gmtime { unop(@_, "gmtime") }
1631 sub pp_alarm { unop(@_, "alarm") }
1632 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1634 sub pp_dofile { unop(@_, "do") }
1635 sub pp_entereval { unop(@_, "eval") }
1637 sub pp_ghbyname { unop(@_, "gethostbyname") }
1638 sub pp_gnbyname { unop(@_, "getnetbyname") }
1639 sub pp_gpbyname { unop(@_, "getprotobyname") }
1640 sub pp_shostent { unop(@_, "sethostent") }
1641 sub pp_snetent { unop(@_, "setnetent") }
1642 sub pp_sprotoent { unop(@_, "setprotoent") }
1643 sub pp_sservent { unop(@_, "setservent") }
1644 sub pp_gpwnam { unop(@_, "getpwnam") }
1645 sub pp_gpwuid { unop(@_, "getpwuid") }
1646 sub pp_ggrnam { unop(@_, "getgrnam") }
1647 sub pp_ggrgid { unop(@_, "getgrgid") }
1649 sub pp_lock { unop(@_, "lock") }
1651 sub pp_continue { unop(@_, "continue"); }
1653 my ($self, $op) = @_;
1654 return "" if $op->flags & OPf_SPECIAL;
1660 my($op, $cx, $givwhen) = @_;
1662 my $enterop = $op->first;
1664 if ($enterop->flags & OPf_SPECIAL) {
1666 $block = $self->deparse($enterop->first, 0);
1669 my $cond = $enterop->first;
1670 my $cond_str = $self->deparse($cond, 1);
1671 $head = "$givwhen ($cond_str)";
1672 $block = $self->deparse($cond->sibling, 0);
1680 sub pp_leavegiven { givwhen(@_, "given"); }
1681 sub pp_leavewhen { givwhen(@_, "when"); }
1687 if ($op->private & OPpEXISTS_SUB) {
1688 # Checking for the existence of a subroutine
1689 return $self->maybe_parens_func("exists",
1690 $self->pp_rv2cv($op->first, 16), $cx, 16);
1692 if ($op->flags & OPf_SPECIAL) {
1693 # Array element, not hash element
1694 return $self->maybe_parens_func("exists",
1695 $self->pp_aelem($op->first, 16), $cx, 16);
1697 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1705 if ($op->private & OPpSLICE) {
1706 if ($op->flags & OPf_SPECIAL) {
1707 # Deleting from an array, not a hash
1708 return $self->maybe_parens_func("delete",
1709 $self->pp_aslice($op->first, 16),
1712 return $self->maybe_parens_func("delete",
1713 $self->pp_hslice($op->first, 16),
1716 if ($op->flags & OPf_SPECIAL) {
1717 # Deleting from an array, not a hash
1718 return $self->maybe_parens_func("delete",
1719 $self->pp_aelem($op->first, 16),
1722 return $self->maybe_parens_func("delete",
1723 $self->pp_helem($op->first, 16),
1731 my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
1732 if (class($op) eq "UNOP" and $op->first->name eq "const"
1733 and $op->first->private & OPpCONST_BARE)
1735 my $name = $self->const_sv($op->first)->PV;
1738 return "$opname $name";
1740 $self->unop($op, $cx, $opname);
1747 my $kid = $op->first;
1748 if (not null $kid->sibling) {
1749 # XXX Was a here-doc
1750 return $self->dquote($op);
1752 $self->unop(@_, "scalar");
1759 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
1762 sub anon_hash_or_list {
1766 my($pre, $post) = @{{"anonlist" => ["[","]"],
1767 "anonhash" => ["{","}"]}->{$op->name}};
1769 $op = $op->first->sibling; # skip pushmark
1770 for (; !null($op); $op = $op->sibling) {
1771 $expr = $self->deparse($op, 6);
1774 if ($pre eq "{" and $cx < 1) {
1775 # Disambiguate that it's not a block
1778 return $pre . join(", ", @exprs) . $post;
1784 if ($op->flags & OPf_SPECIAL) {
1785 return $self->anon_hash_or_list($op, $cx);
1787 warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
1791 *pp_anonhash = \&pp_anonlist;
1796 my $kid = $op->first;
1797 if ($kid->name eq "null") {
1799 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1800 return $self->anon_hash_or_list($op, $cx);
1801 } elsif (!null($kid->sibling) and
1802 $kid->sibling->name eq "anoncode") {
1804 $self->deparse_sub($self->padval($kid->sibling->targ));
1805 } elsif ($kid->name eq "pushmark") {
1806 my $sib_name = $kid->sibling->name;
1807 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1808 and not $kid->sibling->flags & OPf_REF)
1810 # The @a in \(@a) isn't in ref context, but only when the
1812 return "\\(" . $self->pp_list($op->first) . ")";
1813 } elsif ($sib_name eq 'entersub') {
1814 my $text = $self->deparse($kid->sibling, 1);
1815 # Always show parens for \(&func()), but only with -p otherwise
1816 $text = "($text)" if $self->{'parens'}
1817 or $kid->sibling->private & OPpENTERSUB_AMPER;
1822 $self->pfixop($op, $cx, "\\", 20);
1825 sub pp_srefgen { pp_refgen(@_) }
1830 my $kid = $op->first;
1831 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1832 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1833 return $self->unop($op, $cx, "readline");
1839 return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
1842 # Unary operators that can occur as pseudo-listops inside double quotes
1845 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1847 if ($op->flags & OPf_KIDS) {
1849 # If there's more than one kid, the first is an ex-pushmark.
1850 $kid = $kid->sibling if not null $kid->sibling;
1851 return $self->maybe_parens_unop($name, $kid, $cx);
1853 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1857 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1858 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1859 sub pp_uc { dq_unop(@_, "uc") }
1860 sub pp_lc { dq_unop(@_, "lc") }
1861 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1865 my ($op, $cx, $name) = @_;
1866 if (class($op) eq "PVOP") {
1867 return "$name " . $op->pv;
1868 } elsif (class($op) eq "OP") {
1870 } elsif (class($op) eq "UNOP") {
1871 # Note -- loop exits are actually exempt from the
1872 # looks-like-a-func rule, but a few extra parens won't hurt
1873 return $self->maybe_parens_unop($name, $op->first, $cx);
1877 sub pp_last { loopex(@_, "last") }
1878 sub pp_next { loopex(@_, "next") }
1879 sub pp_redo { loopex(@_, "redo") }
1880 sub pp_goto { loopex(@_, "goto") }
1881 sub pp_dump { loopex(@_, "dump") }
1885 my($op, $cx, $name) = @_;
1886 if (class($op) eq "UNOP") {
1887 # Genuine `-X' filetests are exempt from the LLAFR, but not
1888 # l?stat(); for the sake of clarity, give'em all parens
1889 return $self->maybe_parens_unop($name, $op->first, $cx);
1890 } elsif (class($op) =~ /^(SV|PAD)OP$/) {
1891 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1892 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1897 sub pp_lstat { ftst(@_, "lstat") }
1898 sub pp_stat { ftst(@_, "stat") }
1899 sub pp_ftrread { ftst(@_, "-R") }
1900 sub pp_ftrwrite { ftst(@_, "-W") }
1901 sub pp_ftrexec { ftst(@_, "-X") }
1902 sub pp_fteread { ftst(@_, "-r") }
1903 sub pp_ftewrite { ftst(@_, "-w") }
1904 sub pp_fteexec { ftst(@_, "-x") }
1905 sub pp_ftis { ftst(@_, "-e") }
1906 sub pp_fteowned { ftst(@_, "-O") }
1907 sub pp_ftrowned { ftst(@_, "-o") }
1908 sub pp_ftzero { ftst(@_, "-z") }
1909 sub pp_ftsize { ftst(@_, "-s") }
1910 sub pp_ftmtime { ftst(@_, "-M") }
1911 sub pp_ftatime { ftst(@_, "-A") }
1912 sub pp_ftctime { ftst(@_, "-C") }
1913 sub pp_ftsock { ftst(@_, "-S") }
1914 sub pp_ftchr { ftst(@_, "-c") }
1915 sub pp_ftblk { ftst(@_, "-b") }
1916 sub pp_ftfile { ftst(@_, "-f") }
1917 sub pp_ftdir { ftst(@_, "-d") }
1918 sub pp_ftpipe { ftst(@_, "-p") }
1919 sub pp_ftlink { ftst(@_, "-l") }
1920 sub pp_ftsuid { ftst(@_, "-u") }
1921 sub pp_ftsgid { ftst(@_, "-g") }
1922 sub pp_ftsvtx { ftst(@_, "-k") }
1923 sub pp_fttty { ftst(@_, "-t") }
1924 sub pp_fttext { ftst(@_, "-T") }
1925 sub pp_ftbinary { ftst(@_, "-B") }
1927 sub SWAP_CHILDREN () { 1 }
1928 sub ASSIGN () { 2 } # has OP= variant
1929 sub LIST_CONTEXT () { 4 } # Assignment is in list context
1935 my $name = $op->name;
1936 if ($name eq "concat" and $op->first->name eq "concat") {
1937 # avoid spurious `=' -- see comment in pp_concat
1940 if ($name eq "null" and class($op) eq "UNOP"
1941 and $op->first->name =~ /^(and|x?or)$/
1942 and null $op->first->sibling)
1944 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1945 # with a null that's used as the common end point of the two
1946 # flows of control. For precedence purposes, ignore it.
1947 # (COND_EXPRs have these too, but we don't bother with
1948 # their associativity).
1949 return assoc_class($op->first);
1951 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1954 # Left associative operators, like `+', for which
1955 # $a + $b + $c is equivalent to ($a + $b) + $c
1958 %left = ('multiply' => 19, 'i_multiply' => 19,
1959 'divide' => 19, 'i_divide' => 19,
1960 'modulo' => 19, 'i_modulo' => 19,
1962 'add' => 18, 'i_add' => 18,
1963 'subtract' => 18, 'i_subtract' => 18,
1965 'left_shift' => 17, 'right_shift' => 17,
1967 'bit_or' => 12, 'bit_xor' => 12,
1969 'or' => 2, 'xor' => 2,
1973 sub deparse_binop_left {
1975 my($op, $left, $prec) = @_;
1976 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1977 and $left{assoc_class($op)} == $left{assoc_class($left)})
1979 return $self->deparse($left, $prec - .00001);
1981 return $self->deparse($left, $prec);
1985 # Right associative operators, like `=', for which
1986 # $a = $b = $c is equivalent to $a = ($b = $c)
1989 %right = ('pow' => 22,
1990 'sassign=' => 7, 'aassign=' => 7,
1991 'multiply=' => 7, 'i_multiply=' => 7,
1992 'divide=' => 7, 'i_divide=' => 7,
1993 'modulo=' => 7, 'i_modulo=' => 7,
1995 'add=' => 7, 'i_add=' => 7,
1996 'subtract=' => 7, 'i_subtract=' => 7,
1998 'left_shift=' => 7, 'right_shift=' => 7,
2000 'bit_or=' => 7, 'bit_xor=' => 7,
2006 sub deparse_binop_right {
2008 my($op, $right, $prec) = @_;
2009 if ($right{assoc_class($op)} && $right{assoc_class($right)}
2010 and $right{assoc_class($op)} == $right{assoc_class($right)})
2012 return $self->deparse($right, $prec - .00001);
2014 return $self->deparse($right, $prec);
2020 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
2021 my $left = $op->first;
2022 my $right = $op->last;
2024 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
2028 if ($flags & SWAP_CHILDREN) {
2029 ($left, $right) = ($right, $left);
2031 $left = $self->deparse_binop_left($op, $left, $prec);
2032 $left = "($left)" if $flags & LIST_CONTEXT
2033 && $left !~ /^(my|our|local|)[\@\(]/;
2034 $right = $self->deparse_binop_right($op, $right, $prec);
2035 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
2038 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2039 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2040 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
2041 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2042 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2043 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2044 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2045 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
2046 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2047 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2048 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
2050 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
2051 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
2052 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
2053 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
2054 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
2056 sub pp_eq { binop(@_, "==", 14) }
2057 sub pp_ne { binop(@_, "!=", 14) }
2058 sub pp_lt { binop(@_, "<", 15) }
2059 sub pp_gt { binop(@_, ">", 15) }
2060 sub pp_ge { binop(@_, ">=", 15) }
2061 sub pp_le { binop(@_, "<=", 15) }
2062 sub pp_ncmp { binop(@_, "<=>", 14) }
2063 sub pp_i_eq { binop(@_, "==", 14) }
2064 sub pp_i_ne { binop(@_, "!=", 14) }
2065 sub pp_i_lt { binop(@_, "<", 15) }
2066 sub pp_i_gt { binop(@_, ">", 15) }
2067 sub pp_i_ge { binop(@_, ">=", 15) }
2068 sub pp_i_le { binop(@_, "<=", 15) }
2069 sub pp_i_ncmp { binop(@_, "<=>", 14) }
2071 sub pp_seq { binop(@_, "eq", 14) }
2072 sub pp_sne { binop(@_, "ne", 14) }
2073 sub pp_slt { binop(@_, "lt", 15) }
2074 sub pp_sgt { binop(@_, "gt", 15) }
2075 sub pp_sge { binop(@_, "ge", 15) }
2076 sub pp_sle { binop(@_, "le", 15) }
2077 sub pp_scmp { binop(@_, "cmp", 14) }
2079 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
2080 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
2083 my ($self, $op, $cx) = @_;
2084 if ($op->flags & OPf_SPECIAL) {
2085 return $self->deparse($op->first, $cx);
2088 binop(@_, "~~", 14);
2092 # `.' is special because concats-of-concats are optimized to save copying
2093 # by making all but the first concat stacked. The effect is as if the
2094 # programmer had written `($a . $b) .= $c', except legal.
2095 sub pp_concat { maybe_targmy(@_, \&real_concat) }
2099 my $left = $op->first;
2100 my $right = $op->last;
2103 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
2107 $left = $self->deparse_binop_left($op, $left, $prec);
2108 $right = $self->deparse_binop_right($op, $right, $prec);
2109 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
2112 # `x' is weird when the left arg is a list
2116 my $left = $op->first;
2117 my $right = $op->last;
2120 if ($op->flags & OPf_STACKED) {
2124 if (null($right)) { # list repeat; count is inside left-side ex-list
2125 my $kid = $left->first->sibling; # skip pushmark
2127 for (; !null($kid->sibling); $kid = $kid->sibling) {
2128 push @exprs, $self->deparse($kid, 6);
2131 $left = "(" . join(", ", @exprs). ")";
2133 $left = $self->deparse_binop_left($op, $left, $prec);
2135 $right = $self->deparse_binop_right($op, $right, $prec);
2136 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
2141 my ($op, $cx, $type) = @_;
2142 my $left = $op->first;
2143 my $right = $left->sibling;
2144 $left = $self->deparse($left, 9);
2145 $right = $self->deparse($right, 9);
2146 return $self->maybe_parens("$left $type $right", $cx, 9);
2152 my $flip = $op->first;
2153 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
2154 return $self->range($flip->first, $cx, $type);
2157 # one-line while/until is handled in pp_leave
2161 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
2162 my $left = $op->first;
2163 my $right = $op->first->sibling;
2164 if ($cx < 1 and is_scope($right) and $blockname
2165 and $self->{'expand'} < 7)
2167 $left = $self->deparse($left, 1);
2168 $right = $self->deparse($right, 0);
2169 return "$blockname ($left) {\n\t$right\n\b}\cK";
2170 } elsif ($cx < 1 and $blockname and not $self->{'parens'}
2171 and $self->{'expand'} < 7) { # $b if $a
2172 $right = $self->deparse($right, 1);
2173 $left = $self->deparse($left, 1);
2174 return "$right $blockname $left";
2175 } elsif ($cx > $lowprec and $highop) { # $a && $b
2176 $left = $self->deparse_binop_left($op, $left, $highprec);
2177 $right = $self->deparse_binop_right($op, $right, $highprec);
2178 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
2179 } else { # $a and $b
2180 $left = $self->deparse_binop_left($op, $left, $lowprec);
2181 $right = $self->deparse_binop_right($op, $right, $lowprec);
2182 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
2186 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
2187 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
2188 sub pp_dor { logop(@_, "err", 2, "//", 10, "") }
2190 # xor is syntactically a logop, but it's really a binop (contrary to
2191 # old versions of opcode.pl). Syntax is what matters here.
2192 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
2196 my ($op, $cx, $opname) = @_;
2197 my $left = $op->first;
2198 my $right = $op->first->sibling->first; # skip sassign
2199 $left = $self->deparse($left, 7);
2200 $right = $self->deparse($right, 7);
2201 return $self->maybe_parens("$left $opname $right", $cx, 7);
2204 sub pp_andassign { logassignop(@_, "&&=") }
2205 sub pp_orassign { logassignop(@_, "||=") }
2206 sub pp_dorassign { logassignop(@_, "//=") }
2210 my($op, $cx, $name) = @_;
2212 my $parens = ($cx >= 5) || $self->{'parens'};
2213 my $kid = $op->first->sibling;
2214 return $name if null $kid;
2216 $name = "socketpair" if $name eq "sockpair";
2217 my $proto = prototype("CORE::$name");
2219 && $proto =~ /^;?\*/
2220 && $kid->name eq "rv2gv") {
2221 $first = $self->deparse($kid->first, 6);
2224 $first = $self->deparse($kid, 6);
2226 if ($name eq "chmod" && $first =~ /^\d+$/) {
2227 $first = sprintf("%#o", $first);
2229 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
2230 push @exprs, $first;
2231 $kid = $kid->sibling;
2232 if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
2233 push @exprs, $self->deparse($kid->first, 6);
2234 $kid = $kid->sibling;
2236 for (; !null($kid); $kid = $kid->sibling) {
2237 push @exprs, $self->deparse($kid, 6);
2240 return "$name(" . join(", ", @exprs) . ")";
2242 return "$name " . join(", ", @exprs);
2246 sub pp_bless { listop(@_, "bless") }
2247 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2248 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
2249 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2250 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2251 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2252 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2253 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2254 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2255 sub pp_unpack { listop(@_, "unpack") }
2256 sub pp_pack { listop(@_, "pack") }
2257 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2258 sub pp_splice { listop(@_, "splice") }
2259 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2260 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2261 sub pp_reverse { listop(@_, "reverse") }
2262 sub pp_warn { listop(@_, "warn") }
2263 sub pp_die { listop(@_, "die") }
2264 # Actually, return is exempt from the LLAFR (see examples in this very
2265 # module!), but for consistency's sake, ignore that fact
2266 sub pp_return { listop(@_, "return") }
2267 sub pp_open { listop(@_, "open") }
2268 sub pp_pipe_op { listop(@_, "pipe") }
2269 sub pp_tie { listop(@_, "tie") }
2270 sub pp_binmode { listop(@_, "binmode") }
2271 sub pp_dbmopen { listop(@_, "dbmopen") }
2272 sub pp_sselect { listop(@_, "select") }
2273 sub pp_select { listop(@_, "select") }
2274 sub pp_read { listop(@_, "read") }
2275 sub pp_sysopen { listop(@_, "sysopen") }
2276 sub pp_sysseek { listop(@_, "sysseek") }
2277 sub pp_sysread { listop(@_, "sysread") }
2278 sub pp_syswrite { listop(@_, "syswrite") }
2279 sub pp_send { listop(@_, "send") }
2280 sub pp_recv { listop(@_, "recv") }
2281 sub pp_seek { listop(@_, "seek") }
2282 sub pp_fcntl { listop(@_, "fcntl") }
2283 sub pp_ioctl { listop(@_, "ioctl") }
2284 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2285 sub pp_socket { listop(@_, "socket") }
2286 sub pp_sockpair { listop(@_, "sockpair") }
2287 sub pp_bind { listop(@_, "bind") }
2288 sub pp_connect { listop(@_, "connect") }
2289 sub pp_listen { listop(@_, "listen") }
2290 sub pp_accept { listop(@_, "accept") }
2291 sub pp_shutdown { listop(@_, "shutdown") }
2292 sub pp_gsockopt { listop(@_, "getsockopt") }
2293 sub pp_ssockopt { listop(@_, "setsockopt") }
2294 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2295 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2296 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2297 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2298 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2299 sub pp_link { maybe_targmy(@_, \&listop, "link") }
2300 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2301 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2302 sub pp_open_dir { listop(@_, "opendir") }
2303 sub pp_seekdir { listop(@_, "seekdir") }
2304 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2305 sub pp_system { maybe_targmy(@_, \&listop, "system") }
2306 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2307 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2308 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2309 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2310 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2311 sub pp_shmget { listop(@_, "shmget") }
2312 sub pp_shmctl { listop(@_, "shmctl") }
2313 sub pp_shmread { listop(@_, "shmread") }
2314 sub pp_shmwrite { listop(@_, "shmwrite") }
2315 sub pp_msgget { listop(@_, "msgget") }
2316 sub pp_msgctl { listop(@_, "msgctl") }
2317 sub pp_msgsnd { listop(@_, "msgsnd") }
2318 sub pp_msgrcv { listop(@_, "msgrcv") }
2319 sub pp_semget { listop(@_, "semget") }
2320 sub pp_semctl { listop(@_, "semctl") }
2321 sub pp_semop { listop(@_, "semop") }
2322 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2323 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2324 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2325 sub pp_gsbyname { listop(@_, "getservbyname") }
2326 sub pp_gsbyport { listop(@_, "getservbyport") }
2327 sub pp_syscall { listop(@_, "syscall") }
2332 my $text = $self->dq($op->first->sibling); # skip pushmark
2333 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
2334 or $text =~ /[<>]/) {
2335 return 'glob(' . single_delim('qq', '"', $text) . ')';
2337 return '<' . $text . '>';
2341 # Truncate is special because OPf_SPECIAL makes a bareword first arg
2342 # be a filehandle. This could probably be better fixed in the core
2343 # by moving the GV lookup into ck_truc.
2349 my $parens = ($cx >= 5) || $self->{'parens'};
2350 my $kid = $op->first->sibling;
2352 if ($op->flags & OPf_SPECIAL) {
2353 # $kid is an OP_CONST
2354 $fh = $self->const_sv($kid)->PV;
2356 $fh = $self->deparse($kid, 6);
2357 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2359 my $len = $self->deparse($kid->sibling, 6);
2361 return "truncate($fh, $len)";
2363 return "truncate $fh, $len";
2369 my($op, $cx, $name) = @_;
2371 my $kid = $op->first->sibling;
2373 if ($op->flags & OPf_STACKED) {
2375 $indir = $indir->first; # skip rv2gv
2376 if (is_scope($indir)) {
2377 $indir = "{" . $self->deparse($indir, 0) . "}";
2378 $indir = "{;}" if $indir eq "{}";
2379 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
2380 $indir = $self->const_sv($indir)->PV;
2382 $indir = $self->deparse($indir, 24);
2384 $indir = $indir . " ";
2385 $kid = $kid->sibling;
2387 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
2388 $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
2391 elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
2392 $indir = '{$b cmp $a} ';
2394 for (; !null($kid); $kid = $kid->sibling) {
2395 $expr = $self->deparse($kid, 6);
2399 if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
2400 $name2 = 'reverse sort';
2402 if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
2403 return "$exprs[0] = $name2 $indir $exprs[0]";
2406 my $args = $indir . join(", ", @exprs);
2407 if ($indir ne "" and $name eq "sort") {
2408 # We don't want to say "sort(f 1, 2, 3)", since perl -w will
2409 # give bareword warnings in that case. Therefore if context
2410 # requires, we'll put parens around the outside "(sort f 1, 2,
2411 # 3)". Unfortunately, we'll currently think the parens are
2412 # necessary more often that they really are, because we don't
2413 # distinguish which side of an assignment we're on.
2415 return "($name2 $args)";
2417 return "$name2 $args";
2420 return $self->maybe_parens_func($name2, $args, $cx, 5);
2425 sub pp_prtf { indirop(@_, "printf") }
2426 sub pp_print { indirop(@_, "print") }
2427 sub pp_sort { indirop(@_, "sort") }
2431 my($op, $cx, $name) = @_;
2433 my $kid = $op->first; # this is the (map|grep)start
2434 $kid = $kid->first->sibling; # skip a pushmark
2435 my $code = $kid->first; # skip a null
2436 if (is_scope $code) {
2437 $code = "{" . $self->deparse($code, 0) . "} ";
2439 $code = $self->deparse($code, 24) . ", ";
2441 $kid = $kid->sibling;
2442 for (; !null($kid); $kid = $kid->sibling) {
2443 $expr = $self->deparse($kid, 6);
2444 push @exprs, $expr if defined $expr;
2446 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2449 sub pp_mapwhile { mapop(@_, "map") }
2450 sub pp_grepwhile { mapop(@_, "grep") }
2451 sub pp_mapstart { baseop(@_, "map") }
2452 sub pp_grepstart { baseop(@_, "grep") }
2458 my $kid = $op->first->sibling; # skip pushmark
2460 my $local = "either"; # could be local(...), my(...), state(...) or our(...)
2461 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2462 # This assumes that no other private flags equal 128, and that
2463 # OPs that store things other than flags in their op_private,
2464 # like OP_AELEMFAST, won't be immediate children of a list.
2466 # OP_ENTERSUB can break this logic, so check for it.
2467 # I suspect that open and exit can too.
2469 if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
2470 or $lop->name eq "undef")
2471 or $lop->name eq "entersub"
2472 or $lop->name eq "exit"
2473 or $lop->name eq "open")
2475 $local = ""; # or not
2478 if ($lop->name =~ /^pad[ash]v$/) {
2479 if ($lop->private & OPpPAD_STATE) { # state()
2480 ($local = "", last) if $local =~ /^(?:local|our|my)$/;
2483 ($local = "", last) if $local =~ /^(?:local|our|state)$/;
2486 } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
2487 && $lop->private & OPpOUR_INTRO
2488 or $lop->name eq "null" && $lop->first->name eq "gvsv"
2489 && $lop->first->private & OPpOUR_INTRO) { # our()
2490 ($local = "", last) if $local =~ /^(?:my|local|state)$/;
2492 } elsif ($lop->name ne "undef"
2493 # specifically avoid the "reverse sort" optimisation,
2494 # where "reverse" is nullified
2495 && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
2498 ($local = "", last) if $local =~ /^(?:my|our|state)$/;
2502 $local = "" if $local eq "either"; # no point if it's all undefs
2503 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2504 for (; !null($kid); $kid = $kid->sibling) {
2506 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2511 $self->{'avoid_local'}{$$lop}++;
2512 $expr = $self->deparse($kid, 6);
2513 delete $self->{'avoid_local'}{$$lop};
2515 $expr = $self->deparse($kid, 6);
2520 return "$local(" . join(", ", @exprs) . ")";
2522 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2526 sub is_ifelse_cont {
2528 return ($op->name eq "null" and class($op) eq "UNOP"
2529 and $op->first->name =~ /^(and|cond_expr)$/
2530 and is_scope($op->first->first->sibling));
2536 my $cond = $op->first;
2537 my $true = $cond->sibling;
2538 my $false = $true->sibling;
2539 my $cuddle = $self->{'cuddle'};
2540 unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
2541 (is_scope($false) || is_ifelse_cont($false))
2542 and $self->{'expand'} < 7) {
2543 $cond = $self->deparse($cond, 8);
2544 $true = $self->deparse($true, 6);
2545 $false = $self->deparse($false, 8);
2546 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2549 $cond = $self->deparse($cond, 1);
2550 $true = $self->deparse($true, 0);
2551 my $head = "if ($cond) {\n\t$true\n\b}";
2553 while (!null($false) and is_ifelse_cont($false)) {
2554 my $newop = $false->first;
2555 my $newcond = $newop->first;
2556 my $newtrue = $newcond->sibling;
2557 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2558 $newcond = $self->deparse($newcond, 1);
2559 $newtrue = $self->deparse($newtrue, 0);
2560 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2562 if (!null($false)) {
2563 $false = $cuddle . "else {\n\t" .
2564 $self->deparse($false, 0) . "\n\b}\cK";
2568 return $head . join($cuddle, "", @elsifs) . $false;
2573 my($op, $cx, $init) = @_;
2574 my $enter = $op->first;
2575 my $kid = $enter->sibling;
2576 local(@$self{qw'curstash warnings hints'})
2577 = @$self{qw'curstash warnings hints'};
2582 if ($kid->name eq "lineseq") { # bare or infinite loop
2583 if ($kid->last->name eq "unstack") { # infinite
2584 $head = "while (1) "; # Can't use for(;;) if there's a continue
2590 } elsif ($enter->name eq "enteriter") { # foreach
2591 my $ary = $enter->first->sibling; # first was pushmark
2592 my $var = $ary->sibling;
2593 if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
2594 # "reverse" was optimised away
2595 $ary = listop($self, $ary->first->sibling, 1, 'reverse');
2596 } elsif ($enter->flags & OPf_STACKED
2597 and not null $ary->first->sibling->sibling)
2599 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2600 $self->deparse($ary->first->sibling->sibling, 9);
2602 $ary = $self->deparse($ary, 1);
2605 if ($enter->flags & OPf_SPECIAL) { # thread special var
2606 $var = $self->pp_threadsv($enter, 1);
2607 } else { # regular my() variable
2608 $var = $self->pp_padsv($enter, 1);
2610 } elsif ($var->name eq "rv2gv") {
2611 $var = $self->pp_rv2sv($var, 1);
2612 if ($enter->private & OPpOUR_INTRO) {
2613 # our declarations don't have package names
2614 $var =~ s/^(.).*::/$1/;
2617 } elsif ($var->name eq "gv") {
2618 $var = "\$" . $self->deparse($var, 1);
2620 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2621 if (!is_state $body->first and $body->first->name ne "stub") {
2622 confess unless $var eq '$_';
2623 $body = $body->first;
2624 return $self->deparse($body, 2) . " foreach ($ary)";
2626 $head = "foreach $var ($ary) ";
2627 } elsif ($kid->name eq "null") { # while/until
2629 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2630 $cond = $self->deparse($kid->first, 1);
2631 $head = "$name ($cond) ";
2632 $body = $kid->first->sibling;
2633 } elsif ($kid->name eq "stub") { # bare and empty
2634 return "{;}"; # {} could be a hashref
2636 # If there isn't a continue block, then the next pointer for the loop
2637 # will point to the unstack, which is kid's last child, except
2638 # in a bare loop, when it will point to the leaveloop. When neither of
2639 # these conditions hold, then the second-to-last child is the continue
2640 # block (or the last in a bare loop).
2641 my $cont_start = $enter->nextop;
2643 if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
2645 $cont = $body->last;
2647 $cont = $body->first;
2648 while (!null($cont->sibling->sibling)) {
2649 $cont = $cont->sibling;
2652 my $state = $body->first;
2653 my $cuddle = $self->{'cuddle'};
2655 for (; $$state != $$cont; $state = $state->sibling) {
2656 push @states, $state;
2658 $body = $self->lineseq(undef, @states);
2659 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2660 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2663 $cont = $cuddle . "continue {\n\t" .
2664 $self->deparse($cont, 0) . "\n\b}\cK";
2667 return "" if !defined $body;
2669 $head = "for ($init; $cond;) ";
2672 $body = $self->deparse($body, 0);
2674 $body =~ s/;?$/;\n/;
2676 return $head . "{\n\t" . $body . "\b}" . $cont;
2679 sub pp_leaveloop { loop_common(@_, "") }
2684 my $init = $self->deparse($op, 1);
2685 return $self->loop_common($op->sibling->first->sibling, $cx, $init);
2690 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2693 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2694 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2695 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
2696 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
2701 if (class($op) eq "OP") {
2703 return $self->{'ex_const'} if $op->targ == OP_CONST;
2704 } elsif ($op->first->name eq "pushmark") {
2705 return $self->pp_list($op, $cx);
2706 } elsif ($op->first->name eq "enter") {
2707 return $self->pp_leave($op, $cx);
2708 } elsif ($op->first->name eq "leave") {
2709 return $self->pp_leave($op->first, $cx);
2710 } elsif ($op->first->name eq "scope") {
2711 return $self->pp_scope($op->first, $cx);
2712 } elsif ($op->targ == OP_STRINGIFY) {
2713 return $self->dquote($op, $cx);
2714 } elsif (!null($op->first->sibling) and
2715 $op->first->sibling->name eq "readline" and
2716 $op->first->sibling->flags & OPf_STACKED) {
2717 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2718 . $self->deparse($op->first->sibling, 7),
2720 } elsif (!null($op->first->sibling) and
2721 $op->first->sibling->name eq "trans" and
2722 $op->first->sibling->flags & OPf_STACKED) {
2723 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2724 . $self->deparse($op->first->sibling, 20),
2726 } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
2727 return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2728 } elsif (!null($op->first->sibling) and
2729 $op->first->sibling->name eq "null" and
2730 class($op->first->sibling) eq "UNOP" and
2731 $op->first->sibling->first->flags & OPf_STACKED and
2732 $op->first->sibling->first->name eq "rcatline") {
2733 return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
2734 . $self->deparse($op->first->sibling, 18),
2737 return $self->deparse($op->first, $cx);
2744 return $self->padname_sv($targ)->PVX;
2750 return substr($self->padname($op->targ), 1); # skip $/@/%
2756 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2759 sub pp_padav { pp_padsv(@_) }
2760 sub pp_padhv { pp_padsv(@_) }
2765 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2766 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2767 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2774 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2780 if (class($op) eq "PADOP") {
2781 return $self->padval($op->padix);
2782 } else { # class($op) eq "SVOP"
2790 my $gv = $self->gv_or_padgv($op);
2791 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2792 $self->gv_name($gv)));
2798 my $gv = $self->gv_or_padgv($op);
2799 return $self->gv_name($gv);
2806 if ($op->flags & OPf_SPECIAL) { # optimised PADAV
2807 $name = $self->padname($op->targ);
2811 my $gv = $self->gv_or_padgv($op);
2812 $name = $self->gv_name($gv);
2813 $name = $self->{'curstash'}."::$name"
2814 if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2815 $name = '$' . $name;
2818 return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
2823 my($op, $cx, $type) = @_;
2825 if (class($op) eq 'NULL' || !$op->can("first")) {
2826 carp("Unexpected op in pp_rv2x");
2829 my $kid = $op->first;
2830 if ($kid->name eq "gv") {
2831 return $self->stash_variable($type, $self->deparse($kid, 0));
2832 } elsif (is_scalar $kid) {
2833 my $str = $self->deparse($kid, 0);
2834 if ($str =~ /^\$([^\w\d])\z/) {
2835 # "$$+" isn't a legal way to write the scalar dereference
2836 # of $+, since the lexer can't tell you aren't trying to
2837 # do something like "$$ + 1" to get one more than your
2838 # PID. Either "${$+}" or "$${+}" are workable
2839 # disambiguations, but if the programmer did the former,
2840 # they'd be in the "else" clause below rather than here.
2841 # It's not clear if this should somehow be unified with
2842 # the code in dq and re_dq that also adds lexer
2843 # disambiguation braces.
2844 $str = '$' . "{$1}"; #'
2846 return $type . $str;
2848 return $type . "{" . $self->deparse($kid, 0) . "}";
2852 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2853 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2854 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2860 if ($op->first->name eq "padav") {
2861 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2863 return $self->maybe_local($op, $cx,
2864 $self->rv2x($op->first, $cx, '$#'));
2868 # skip down to the old, ex-rv2cv
2870 my ($self, $op, $cx) = @_;
2871 if (!null($op->first) && $op->first->name eq 'null' &&
2872 $op->first->targ eq OP_LIST)
2874 return $self->rv2x($op->first->first->sibling, $cx, "&")
2877 return $self->rv2x($op, $cx, "")
2883 my($cx, @list) = @_;
2884 my @a = map $self->const($_, 6), @list;
2889 } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
2890 # collapse (-1,0,1,2) into (-1..2)
2891 my ($s, $e) = @a[0,-1];
2893 return $self->maybe_parens("$s..$e", $cx, 9)
2894 unless grep $i++ != $_, @a;
2896 return $self->maybe_parens(join(", ", @a), $cx, 6);
2902 my $kid = $op->first;
2903 if ($kid->name eq "const") { # constant list
2904 my $av = $self->const_sv($kid);
2905 return $self->list_const($cx, $av->ARRAY);
2907 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2911 sub is_subscriptable {
2913 if ($op->name =~ /^[ahg]elem/) {
2915 } elsif ($op->name eq "entersub") {
2916 my $kid = $op->first;
2917 return 0 unless null $kid->sibling;
2919 $kid = $kid->sibling until null $kid->sibling;
2920 return 0 if is_scope($kid);
2922 return 0 if $kid->name eq "gv";
2923 return 0 if is_scalar($kid);
2924 return is_subscriptable($kid);
2930 sub elem_or_slice_array_name
2933 my ($array, $left, $padname, $allow_arrow) = @_;
2935 if ($array->name eq $padname) {
2936 return $self->padany($array);
2937 } elsif (is_scope($array)) { # ${expr}[0]
2938 return "{" . $self->deparse($array, 0) . "}";
2939 } elsif ($array->name eq "gv") {
2940 $array = $self->gv_name($self->gv_or_padgv($array));
2941 if ($array !~ /::/) {
2942 my $prefix = ($left eq '[' ? '@' : '%');
2943 $array = $self->{curstash}.'::'.$array
2944 if $self->lex_in_scope($prefix . $array);
2947 } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
2948 return $self->deparse($array, 24);
2954 sub elem_or_slice_single_index
2959 $idx = $self->deparse($idx, 1);
2961 # Outer parens in an array index will confuse perl
2962 # if we're interpolating in a regular expression, i.e.
2963 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2965 # If $self->{parens}, then an initial '(' will
2966 # definitely be paired with a final ')'. If
2967 # !$self->{parens}, the misleading parens won't
2968 # have been added in the first place.
2970 # [You might think that we could get "(...)...(...)"
2971 # where the initial and final parens do not match
2972 # each other. But we can't, because the above would
2973 # only happen if there's an infix binop between the
2974 # two pairs of parens, and *that* means that the whole
2975 # expression would be parenthesized as well.]
2977 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2979 # Hash-element braces will autoquote a bareword inside themselves.
2980 # We need to make sure that C<$hash{warn()}> doesn't come out as
2981 # C<$hash{warn}>, which has a quite different meaning. Currently
2982 # B::Deparse will always quote strings, even if the string was a
2983 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
2984 # for constant strings.) So we can cheat slightly here - if we see
2985 # a bareword, we know that it is supposed to be a function call.
2987 $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
2994 my ($op, $cx, $left, $right, $padname) = @_;
2995 my($array, $idx) = ($op->first, $op->first->sibling);
2997 $idx = $self->elem_or_slice_single_index($idx);
2999 unless ($array->name eq $padname) { # Maybe this has been fixed
3000 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
3002 if (my $array_name=$self->elem_or_slice_array_name
3003 ($array, $left, $padname, 1)) {
3004 return "\$" . $array_name . $left . $idx . $right;
3006 # $x[20][3]{hi} or expr->[20]
3007 my $arrow = is_subscriptable($array) ? "" : "->";
3008 return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
3013 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
3014 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
3019 my($glob, $part) = ($op->first, $op->last);
3020 $glob = $glob->first; # skip rv2gv
3021 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
3022 my $scope = is_scope($glob);
3023 $glob = $self->deparse($glob, 0);
3024 $part = $self->deparse($part, 1);
3025 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
3030 my ($op, $cx, $left, $right, $regname, $padname) = @_;
3032 my(@elems, $kid, $array, $list);
3033 if (class($op) eq "LISTOP") {
3035 } else { # ex-hslice inside delete()
3036 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
3040 $array = $array->first
3041 if $array->name eq $regname or $array->name eq "null";
3042 $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
3043 $kid = $op->first->sibling; # skip pushmark
3044 if ($kid->name eq "list") {
3045 $kid = $kid->first->sibling; # skip list, pushmark
3046 for (; !null $kid; $kid = $kid->sibling) {
3047 push @elems, $self->deparse($kid, 6);
3049 $list = join(", ", @elems);
3051 $list = $self->elem_or_slice_single_index($kid);
3053 return "\@" . $array . $left . $list . $right;
3056 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
3057 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
3062 my $idx = $op->first;
3063 my $list = $op->last;
3065 $list = $self->deparse($list, 1);
3066 $idx = $self->deparse($idx, 1);
3067 return "($list)" . "[$idx]";
3072 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
3077 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
3083 my $kid = $op->first->sibling; # skip pushmark
3084 my($meth, $obj, @exprs);
3085 if ($kid->name eq "list" and want_list $kid) {
3086 # When an indirect object isn't a bareword but the args are in
3087 # parens, the parens aren't part of the method syntax (the LLAFR
3088 # doesn't apply), but they make a list with OPf_PARENS set that
3089 # doesn't get flattened by the append_elem that adds the method,
3090 # making a (object, arg1, arg2, ...) list where the object
3091 # usually is. This can be distinguished from
3092 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
3093 # object) because in the later the list is in scalar context
3094 # as the left side of -> always is, while in the former
3095 # the list is in list context as method arguments always are.
3096 # (Good thing there aren't method prototypes!)
3097 $meth = $kid->sibling;
3098 $kid = $kid->first->sibling; # skip pushmark
3100 $kid = $kid->sibling;
3101 for (; not null $kid; $kid = $kid->sibling) {
3102 push @exprs, $self->deparse($kid, 6);
3106 $kid = $kid->sibling;
3107 for (; !null ($kid->sibling) && $kid->name ne "method_named";
3108 $kid = $kid->sibling) {
3109 push @exprs, $self->deparse($kid, 6);
3113 $obj = $self->deparse($obj, 24);
3114 if ($meth->name eq "method_named") {
3115 $meth = $self->const_sv($meth)->PV;
3117 $meth = $meth->first;
3118 if ($meth->name eq "const") {
3119 # As of 5.005_58, this case is probably obsoleted by the
3120 # method_named case above
3121 $meth = $self->const_sv($meth)->PV; # needs to be bare
3123 $meth = $self->deparse($meth, 1);
3126 my $args = join(", ", @exprs);
3127 $kid = $obj . "->" . $meth;
3129 return $kid . "(" . $args . ")"; # parens mandatory
3135 # returns "&" if the prototype doesn't match the args,
3136 # or ("", $args_after_prototype_demunging) if it does.
3139 return "&" if $self->{'noproto'};
3140 my($proto, @args) = @_;
3144 # An unbackslashed @ or % gobbles up the rest of the args
3145 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
3147 $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//;
3150 return "&" if @args;
3151 } elsif ($chr eq ";") {
3153 } elsif ($chr eq "@" or $chr eq "%") {
3154 push @reals, map($self->deparse($_, 6), @args);
3160 if (want_scalar $arg) {
3161 push @reals, $self->deparse($arg, 6);
3165 } elsif ($chr eq "&") {
3166 if ($arg->name =~ /^(s?refgen|undef)$/) {
3167 push @reals, $self->deparse($arg, 6);
3171 } elsif ($chr eq "*") {
3172 if ($arg->name =~ /^s?refgen$/
3173 and $arg->first->first->name eq "rv2gv")
3175 $real = $arg->first->first; # skip refgen, null
3176 if ($real->first->name eq "gv") {
3177 push @reals, $self->deparse($real, 6);
3179 push @reals, $self->deparse($real->first, 6);
3184 } elsif (substr($chr, 0, 1) eq "\\") {
3186 if ($arg->name =~ /^s?refgen$/ and
3187 !null($real = $arg->first) and
3188 ($chr =~ /\$/ && is_scalar($real->first)
3190 && class($real->first->sibling) ne 'NULL'
3191 && $real->first->sibling->name
3194 && class($real->first->sibling) ne 'NULL'
3195 && $real->first->sibling->name
3197 #or ($chr =~ /&/ # This doesn't work
3198 # && $real->first->name eq "rv2cv")
3200 && $real->first->name eq "rv2gv")))
3202 push @reals, $self->deparse($real, 6);
3209 return "&" if $proto and !$doneok; # too few args and no `;'
3210 return "&" if @args; # too many args
3211 return ("", join ", ", @reals);
3217 return $self->method($op, $cx) unless null $op->first->sibling;
3221 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
3223 } elsif ($op->private & OPpENTERSUB_AMPER) {
3227 $kid = $kid->first->sibling; # skip ex-list, pushmark
3228 for (; not null $kid->sibling; $kid = $kid->sibling) {
3233 if (is_scope($kid)) {
3235 $kid = "{" . $self->deparse($kid, 0) . "}";
3236 } elsif ($kid->first->name eq "gv") {
3237 my $gv = $self->gv_or_padgv($kid->first);
3238 if (class($gv->CV) ne "SPECIAL") {
3239 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
3241 $simple = 1; # only calls of named functions can be prototyped
3242 $kid = $self->deparse($kid, 24);
3243 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
3245 $kid = $self->deparse($kid, 24);
3248 my $arrow = is_subscriptable($kid->first) ? "" : "->";
3249 $kid = $self->deparse($kid, 24) . $arrow;
3252 # Doesn't matter how many prototypes there are, if
3253 # they haven't happened yet!
3257 no warnings 'uninitialized';
3258 $declared = exists $self->{'subs_declared'}{$kid}
3260 defined &{ ${$self->{'curstash'}."::"}{$kid} }
3262 $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
3263 && defined prototype $self->{'curstash'}."::".$kid
3265 if (!$declared && defined($proto)) {
3266 # Avoid "too early to check prototype" warning
3267 ($amper, $proto) = ('&');
3272 if ($declared and defined $proto and not $amper) {
3273 ($amper, $args) = $self->check_proto($proto, @exprs);
3274 if ($amper eq "&") {
3275 $args = join(", ", map($self->deparse($_, 6), @exprs));
3278 $args = join(", ", map($self->deparse($_, 6), @exprs));
3280 if ($prefix or $amper) {
3281 if ($op->flags & OPf_STACKED) {
3282 return $prefix . $amper . $kid . "(" . $args . ")";
3284 return $prefix . $amper. $kid;
3287 # glob() invocations can be translated into calls of
3288 # CORE::GLOBAL::glob with a second parameter, a number.
3290 if ($kid eq "CORE::GLOBAL::glob") {
3292 $args =~ s/\s*,[^,]+$//;
3295 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
3296 # so it must have been translated from a keyword call. Translate
3298 $kid =~ s/^CORE::GLOBAL:://;
3300 my $dproto = defined($proto) ? $proto : "undefined";
3302 return "$kid(" . $args . ")";
3303 } elsif ($dproto eq "") {
3305 } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
3306 # is_scalar is an excessively conservative test here:
3307 # really, we should be comparing to the precedence of the
3308 # top operator of $exprs[0] (ala unop()), but that would
3309 # take some major code restructuring to do right.
3310 return $self->maybe_parens_func($kid, $args, $cx, 16);
3311 } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
3312 return $self->maybe_parens_func($kid, $args, $cx, 5);
3314 return "$kid(" . $args . ")";
3319 sub pp_enterwrite { unop(@_, "write") }
3321 # escape things that cause interpolation in double quotes,
3322 # but not character escapes
3325 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
3333 # Matches any string which is balanced with respect to {braces}
3344 # the same, but treat $|, $), $( and $ at the end of the string differently
3358 (\(\?\??\{$bal\}\)) # $4
3364 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3369 # This is for regular expressions with the /x modifier
3370 # We have to leave comments unmangled.
3371 sub re_uninterp_extended {
3384 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
3385 | \#[^\n]* # (skip over comments)
3392 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3398 my %unctrl = # portable to to EBCDIC
3400 "\c@" => '\c@', # unused
3427 "\c[" => '\c[', # unused
3428 "\c\\" => '\c\\', # unused
3429 "\c]" => '\c]', # unused
3430 "\c_" => '\c_', # unused
3433 # character escapes, but not delimiters that might need to be escaped
3434 sub escape_str { # ASCII, UTF8
3436 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3438 # $str =~ s/\cH/\\b/g; # \b means something different in a regex
3444 $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
3445 $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
3449 # For regexes with the /x modifier.
3450 # Leave whitespace unmangled.
3451 sub escape_extended_re {
3453 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3454 $str =~ s/([[:^print:]])/
3455 ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
3456 $str =~ s/\n/\n\f/g;
3460 # Don't do this for regexen
3463 $str =~ s/\\/\\\\/g;
3467 # Remove backslashes which precede literal control characters,
3468 # to avoid creating ambiguity when we escape the latter.
3472 # the insane complexity here is due to the behaviour of "\c\"
3473 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
3477 sub balanced_delim {
3479 my @str = split //, $str;
3480 my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
3481 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3482 ($open, $close) = @$ar;
3483 $fail = 0; $cnt = 0; $last_bs = 0;
3486 $fail = 1 if $last_bs;
3488 } elsif ($c eq $close) {
3489 $fail = 1 if $last_bs;
3497 $last_bs = $c eq '\\';
3499 $fail = 1 if $cnt != 0;
3500 return ($open, "$open$str$close") if not $fail;
3506 my($q, $default, $str) = @_;
3507 return "$default$str$default" if $default and index($str, $default) == -1;
3509 (my $succeed, $str) = balanced_delim($str);
3510 return "$q$str" if $succeed;
3512 for my $delim ('/', '"', '#') {
3513 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3516 $str =~ s/$default/\\$default/g;
3517 return "$default$str$default";
3525 BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
3527 # Split a floating point number into an integer mantissa and a binary
3528 # exponent. Assumes you've already made sure the number isn't zero or
3529 # some weird infinity or NaN.
3533 if ($f == int($f)) {
3534 while ($f % 2 == 0) {
3539 while ($f != int($f)) {
3544 my $mantissa = sprintf("%.0f", $f);
3545 return ($mantissa, $exponent);
3551 if ($self->{'use_dumper'}) {
3552 return $self->const_dumper($sv, $cx);
3554 if (class($sv) eq "SPECIAL") {
3555 # sv_undef, sv_yes, sv_no
3556 return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
3557 } elsif (class($sv) eq "NULL") {
3560 # convert a version object into the "v1.2.3" string in its V magic
3561 if ($sv->FLAGS & SVs_RMG) {
3562 for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
3563 return $mg->PTR if $mg->TYPE eq 'V';
3567 if ($sv->FLAGS & SVf_IOK) {
3568 my $str = $sv->int_value;
3569 $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
3571 } elsif ($sv->FLAGS & SVf_NOK) {
3574 if (pack("F", $nv) eq pack("F", 0)) {
3579 return $self->maybe_parens("-.0", $cx, 21);
3581 } elsif (1/$nv == 0) {
3584 return $self->maybe_parens("9**9**9", $cx, 22);
3587 return $self->maybe_parens("-9**9**9", $cx, 21);
3589 } elsif ($nv != $nv) {
3591 if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
3593 return "sin(9**9**9)";
3594 } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
3596 return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
3599 my $hex = unpack("h*", pack("F", $nv));
3600 return qq'unpack("F", pack("h*", "$hex"))';
3603 # first, try the default stringification
3606 # failing that, try using more precision
3607 $str = sprintf("%.${max_prec}g", $nv);
3608 # if (pack("F", $str) ne pack("F", $nv)) {
3610 # not representable in decimal with whatever sprintf()
3611 # and atof() Perl is using here.
3612 my($mant, $exp) = split_float($nv);
3613 return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
3616 $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
3618 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3620 if (class($ref) eq "AV") {
3621 return "[" . $self->list_const(2, $ref->ARRAY) . "]";
3622 } elsif (class($ref) eq "HV") {
3623 my %hash = $ref->ARRAY;
3625 for my $k (sort keys %hash) {
3626 push @elts, "$k => " . $self->const($hash{$k}, 6);
3628 return "{" . join(", ", @elts) . "}";
3629 } elsif (class($ref) eq "CV") {
3630 return "sub " . $self->deparse_sub($ref);
3632 if ($ref->FLAGS & SVs_SMG) {
3633 for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
3634 if ($mg->TYPE eq 'r') {
3635 my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
3636 return single_delim("qr", "", $re);
3641 return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
3642 } elsif ($sv->FLAGS & SVf_POK) {
3644 if ($str =~ /[[:^print:]]/) {
3645 return single_delim("qq", '"', uninterp escape_str unback $str);
3647 return single_delim("q", "'", unback $str);
3657 my $ref = $sv->object_2svref();
3658 my $dumper = Data::Dumper->new([$$ref], ['$v']);
3659 $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
3660 my $str = $dumper->Dump();
3661 if ($str =~ /^\$v/) {
3662 return '${my ' . $str . ' \$v}';
3672 # the constant could be in the pad (under useithreads)
3673 $sv = $self->padval($op->targ) unless $$sv;
3680 if ($op->private & OPpCONST_ARYBASE) {
3683 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3684 # return $self->const_sv($op)->PV;
3686 my $sv = $self->const_sv($op);
3687 return $self->const($sv, $cx);
3693 my $type = $op->name;
3694 if ($type eq "const") {
3695 return '$[' if $op->private & OPpCONST_ARYBASE;
3696 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3697 } elsif ($type eq "concat") {
3698 my $first = $self->dq($op->first);
3699 my $last = $self->dq($op->last);
3701 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
3702 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3703 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
3704 || ($last =~ /^[:'{\[\w_]/ && #'
3705 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3707 return $first . $last;
3708 } elsif ($type eq "uc") {
3709 return '\U' . $self->dq($op->first->sibling) . '\E';
3710 } elsif ($type eq "lc") {
3711 return '\L' . $self->dq($op->first->sibling) . '\E';
3712 } elsif ($type eq "ucfirst") {
3713 return '\u' . $self->dq($op->first->sibling);
3714 } elsif ($type eq "lcfirst") {
3715 return '\l' . $self->dq($op->first->sibling);
3716 } elsif ($type eq "quotemeta") {
3717 return '\Q' . $self->dq($op->first->sibling) . '\E';
3718 } elsif ($type eq "join") {
3719 return $self->deparse($op->last, 26); # was join($", @ary)
3721 return $self->deparse($op, 26);
3728 # skip pushmark if it exists (readpipe() vs ``)
3729 my $child = $op->first->sibling->isa('B::NULL')
3730 ? $op->first->first : $op->first->sibling;
3731 return single_delim("qx", '`', $self->dq($child));
3737 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3738 return $self->deparse($kid, $cx) if $self->{'unquote'};
3739 $self->maybe_targmy($kid, $cx,
3740 sub {single_delim("qq", '"', $self->dq($_[1]))});
3743 # OP_STRINGIFY is a listop, but it only ever has one arg
3744 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3746 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3747 # note that tr(from)/to/ is OK, but not tr/from/(to)
3749 my($from, $to) = @_;
3750 my($succeed, $delim);
3751 if ($from !~ m[/] and $to !~ m[/]) {
3752 return "/$from/$to/";
3753 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3754 if (($succeed, $to) = balanced_delim($to) and $succeed) {
3757 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3758 return "$from$delim$to$delim" if index($to, $delim) == -1;
3761 return "$from/$to/";
3764 for $delim ('/', '"', '#') { # note no '
3765 return "$delim$from$delim$to$delim"
3766 if index($to . $from, $delim) == -1;
3768 $from =~ s[/][\\/]g;
3770 return "/$from/$to/";
3774 # Only used by tr///, so backslashes hyphens
3777 if ($n == ord '\\') {
3779 } elsif ($n == ord "-") {
3781 } elsif ($n >= ord(' ') and $n <= ord('~')) {
3783 } elsif ($n == ord "\a") {
3785 } elsif ($n == ord "\b") {
3787 } elsif ($n == ord "\t") {
3789 } elsif ($n == ord "\n") {
3791 } elsif ($n == ord "\e") {
3793 } elsif ($n == ord "\f") {
3795 } elsif ($n == ord "\r") {
3797 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3798 return '\\c' . chr(ord("@") + $n);
3800 # return '\x' . sprintf("%02x", $n);
3801 return '\\' . sprintf("%03o", $n);
3807 my($str, $c, $tr) = ("");
3808 for ($c = 0; $c < @chars; $c++) {
3811 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3812 $chars[$c + 2] == $tr + 2)
3814 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3817 $str .= pchr($chars[$c]);
3823 sub tr_decode_byte {
3824 my($table, $flags) = @_;
3825 my(@table) = unpack("s*", $table);
3826 splice @table, 0x100, 1; # Number of subsequent elements
3827 my($c, $tr, @from, @to, @delfrom, $delhyphen);
3828 if ($table[ord "-"] != -1 and
3829 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3831 $tr = $table[ord "-"];
3832 $table[ord "-"] = -1;
3836 } else { # -2 ==> delete
3840 for ($c = 0; $c < @table; $c++) {
3843 push @from, $c; push @to, $tr;
3844 } elsif ($tr == -2) {
3848 @from = (@from, @delfrom);
3849 if ($flags & OPpTRANS_COMPLEMENT) {
3852 @from{@from} = (1) x @from;
3853 for ($c = 0; $c < 256; $c++) {
3854 push @newfrom, $c unless $from{$c};
3858 unless ($flags & OPpTRANS_DELETE || !@to) {
3859 pop @to while $#to and $to[$#to] == $to[$#to -1];
3862 $from = collapse(@from);
3863 $to = collapse(@to);
3864 $from .= "-" if $delhyphen;
3865 return ($from, $to);
3870 if ($x == ord "-") {
3872 } elsif ($x == ord "\\") {
3879 # XXX This doesn't yet handle all cases correctly either
3881 sub tr_decode_utf8 {
3882 my($swash_hv, $flags) = @_;
3883 my %swash = $swash_hv->ARRAY;
3885 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3886 my $none = $swash{"NONE"}->IV;
3887 my $extra = $none + 1;
3888 my(@from, @delfrom, @to);
3890 foreach $line (split /\n/, $swash{'LIST'}->PV) {
3891 my($min, $max, $result) = split(/\t/, $line);
3898 $result = hex $result;
3899 if ($result == $extra) {
3900 push @delfrom, [$min, $max];
3902 push @from, [$min, $max];
3903 push @to, [$result, $result + $max - $min];
3906 for my $i (0 .. $#from) {
3907 if ($from[$i][0] == ord '-') {
3908 unshift @from, splice(@from, $i, 1);
3909 unshift @to, splice(@to, $i, 1);
3911 } elsif ($from[$i][1] == ord '-') {
3914 unshift @from, ord '-';
3915 unshift @to, ord '-';
3919 for my $i (0 .. $#delfrom) {
3920 if ($delfrom[$i][0] == ord '-') {
3921 push @delfrom, splice(@delfrom, $i, 1);
3923 } elsif ($delfrom[$i][1] == ord '-') {
3925 push @delfrom, ord '-';
3929 if (defined $final and $to[$#to][1] != $final) {
3930 push @to, [$final, $final];
3932 push @from, @delfrom;
3933 if ($flags & OPpTRANS_COMPLEMENT) {
3936 for my $i (0 .. $#from) {
3937 push @newfrom, [$next, $from[$i][0] - 1];
3938 $next = $from[$i][1] + 1;
3941 for my $range (@newfrom) {
3942 if ($range->[0] <= $range->[1]) {
3947 my($from, $to, $diff);
3948 for my $chunk (@from) {
3949 $diff = $chunk->[1] - $chunk->[0];
3951 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3952 } elsif ($diff == 1) {
3953 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3955 $from .= tr_chr($chunk->[0]);
3958 for my $chunk (@to) {
3959 $diff = $chunk->[1] - $chunk->[0];
3961 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3962 } elsif ($diff == 1) {
3963 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3965 $to .= tr_chr($chunk->[0]);
3968 #$final = sprintf("%04x", $final) if defined $final;
3969 #$none = sprintf("%04x", $none) if defined $none;
3970 #$extra = sprintf("%04x", $extra) if defined $extra;
3971 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3972 #print STDERR $swash{'LIST'}->PV;
3973 return (escape_str($from), escape_str($to));
3980 if (class($op) eq "PVOP") {
3981 ($from, $to) = tr_decode_byte($op->pv, $op->private);
3982 } else { # class($op) eq "SVOP"
3983 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3986 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3987 $flags .= "d" if $op->private & OPpTRANS_DELETE;
3988 $to = "" if $from eq $to and $flags eq "";
3989 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3990 return "tr" . double_delim($from, $to) . $flags;
3993 # Like dq(), but different
3996 my ($op, $extended) = @_;
3998 my $type = $op->name;
3999 if ($type eq "const") {
4000 return '$[' if $op->private & OPpCONST_ARYBASE;
4001 my $unbacked = re_unback($self->const_sv($op)->as_string);
4002 return re_uninterp_extended(escape_extended_re($unbacked))
4004 return re_uninterp(escape_str($unbacked));
4005 } elsif ($type eq "concat") {
4006 my $first = $self->re_dq($op->first, $extended);
4007 my $last = $self->re_dq($op->last, $extended);
4009 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
4010 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
4011 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
4012 || ($last =~ /^[{\[\w_]/ &&
4013 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
4015 return $first . $last;
4016 } elsif ($type eq "uc") {
4017 return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
4018 } elsif ($type eq "lc") {
4019 return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
4020 } elsif ($type eq "ucfirst") {
4021 return '\u' . $self->re_dq($op->first->sibling, $extended);
4022 } elsif ($type eq "lcfirst") {
4023 return '\l' . $self->re_dq($op->first->sibling, $extended);
4024 } elsif ($type eq "quotemeta") {
4025 return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
4026 } elsif ($type eq "join") {
4027 return $self->deparse($op->last, 26); # was join($", @ary)
4029 return $self->deparse($op, 26);
4034 my ($self, $op) = @_;
4035 return 0 if null $op;
4036 my $type = $op->name;
4038 if ($type eq 'const') {
4041 elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
4042 return $self->pure_string($op->first->sibling);
4044 elsif ($type eq 'join') {
4045 my $join_op = $op->first->sibling; # Skip pushmark
4046 return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
4048 my $gvop = $join_op->first;
4049 return 0 unless $gvop->name eq 'gvsv';
4050 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
4052 return 0 unless ${$join_op->sibling} eq ${$op->last};
4053 return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
4055 elsif ($type eq 'concat') {
4056 return $self->pure_string($op->first)
4057 && $self->pure_string($op->last);
4059 elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
4062 elsif ($type eq "null" and $op->can('first') and not null $op->first and
4063 $op->first->name eq "null" and $op->first->can('first')
4064 and not null $op->first->first and
4065 $op->first->first->name eq "aelemfast") {
4077 my($op, $cx, $extended) = @_;
4078 my $kid = $op->first;
4079 $kid = $kid->first if $kid->name eq "regcmaybe";
4080 $kid = $kid->first if $kid->name eq "regcreset";
4081 if ($kid->name eq "null" and !null($kid->first)
4082 and $kid->first->name eq 'pushmark')
4085 $kid = $kid->first->sibling;
4086 while (!null($kid)) {
4087 $str .= $self->re_dq($kid, $extended);
4088 $kid = $kid->sibling;
4093 return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
4094 return ($self->deparse($kid, $cx), 0);
4098 my ($self, $op, $cx) = @_;
4099 return (($self->regcomp($op, $cx, 0))[0]);
4102 # osmic acid -- see osmium tetroxide
4105 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
4106 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
4107 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
4111 my($op, $cx, $name, $delim) = @_;
4112 my $kid = $op->first;
4113 my ($binop, $var, $re) = ("", "", "");
4114 if ($op->flags & OPf_STACKED) {
4116 $var = $self->deparse($kid, 20);
4117 $kid = $kid->sibling;
4120 my $extended = ($op->pmflags & PMf_EXTENDED);
4122 my $unbacked = re_unback($op->precomp);
4124 $re = re_uninterp_extended(escape_extended_re($unbacked));
4126 $re = re_uninterp(escape_str(re_unback($op->precomp)));
4128 } elsif ($kid->name ne 'regcomp') {
4129 carp("found ".$kid->name." where regcomp expected");
4131 ($re, $quote) = $self->regcomp($kid, 21, $extended);
4134 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
4135 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
4136 $flags .= "i" if $op->pmflags & PMf_FOLD;
4137 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
4138 $flags .= "o" if $op->pmflags & PMf_KEEP;
4139 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
4140 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
4141 $flags = $matchwords{$flags} if $matchwords{$flags};
4142 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
4146 $re = single_delim($name, $delim, $re);
4148 $re = $re . $flags if $quote;
4150 return $self->maybe_parens("$var =~ $re", $cx, 20);
4156 sub pp_match { matchop(@_, "m", "/") }
4157 sub pp_pushre { matchop(@_, "m", "/") }
4158 sub pp_qr { matchop(@_, "qr", "") }
4163 my($kid, @exprs, $ary, $expr);
4166 # For our kid (an OP_PUSHRE), pmreplroot is never actually the
4167 # root of a replacement; it's either empty, or abused to point to
4168 # the GV for an array we split into (an optimization to save
4169 # assignment overhead). Depending on whether we're using ithreads,
4170 # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
4171 # figures out for us which it is.
4172 my $replroot = $kid->pmreplroot;
4174 if (ref($replroot) eq "B::GV") {
4176 } elsif (!ref($replroot) and $replroot > 0) {
4177 $gv = $self->padval($replroot);
4179 $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
4181 for (; !null($kid); $kid = $kid->sibling) {
4182 push @exprs, $self->deparse($kid, 6);
4185 # handle special case of split(), and split(' ') that compiles to /\s+/
4187 if ($kid->flags & OPf_SPECIAL and $kid->pmflags & PMf_SKIPWHITE) {
4191 $expr = "split(" . join(", ", @exprs) . ")";
4193 return $self->maybe_parens("$ary = $expr", $cx, 7);
4199 # oxime -- any of various compounds obtained chiefly by the action of
4200 # hydroxylamine on aldehydes and ketones and characterized by the
4201 # bivalent grouping C=NOH [Webster's Tenth]
4204 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
4205 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
4206 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
4207 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
4212 my $kid = $op->first;
4213 my($binop, $var, $re, $repl) = ("", "", "", "");
4214 if ($op->flags & OPf_STACKED) {
4216 $var = $self->deparse($kid, 20);
4217 $kid = $kid->sibling;
4220 if (null($op->pmreplroot)) {
4221 $repl = $self->dq($kid);
4222 $kid = $kid->sibling;
4224 $repl = $op->pmreplroot->first; # skip substcont
4225 while ($repl->name eq "entereval") {
4226 $repl = $repl->first;
4229 if ($op->pmflags & PMf_EVAL) {
4230 $repl = $self->deparse($repl->first, 0);
4232 $repl = $self->dq($repl);
4235 my $extended = ($op->pmflags & PMf_EXTENDED);
4237 my $unbacked = re_unback($op->precomp);
4239 $re = re_uninterp_extended(escape_extended_re($unbacked));
4242 $re = re_uninterp(escape_str($unbacked));
4245 ($re) = $self->regcomp($kid, 1, $extended);
4247 $flags .= "e" if $op->pmflags & PMf_EVAL;
4248 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
4249 $flags .= "i" if $op->pmflags & PMf_FOLD;
4250 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
4251 $flags .= "o" if $op->pmflags & PMf_KEEP;
4252 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
4253 $flags .= "x" if $extended;
4254 $flags = $substwords{$flags} if $substwords{$flags};
4256 return $self->maybe_parens("$var =~ s"
4257 . double_delim($re, $repl) . $flags,
4260 return "s". double_delim($re, $repl) . $flags;
4269 B::Deparse - Perl compiler backend to produce perl code
4273 B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
4274 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
4278 B::Deparse is a backend module for the Perl compiler that generates
4279 perl source code, based on the internal compiled structure that perl
4280 itself creates after parsing a program. The output of B::Deparse won't
4281 be exactly the same as the original source, since perl doesn't keep
4282 track of comments or whitespace, and there isn't a one-to-one
4283 correspondence between perl's syntactical constructions and their
4284 compiled form, but it will often be close. When you use the B<-p>
4285 option, the output also includes parentheses even when they are not
4286 required by precedence, which can make it easy to see if perl is
4287 parsing your expressions the way you intended.
4289 While B::Deparse goes to some lengths to try to figure out what your
4290 original program was doing, some parts of the language can still trip
4291 it up; it still fails even on some parts of Perl's own test suite. If
4292 you encounter a failure other than the most common ones described in
4293 the BUGS section below, you can help contribute to B::Deparse's
4294 ongoing development by submitting a bug report with a small
4299 As with all compiler backend options, these must follow directly after
4300 the '-MO=Deparse', separated by a comma but not any white space.
4306 Output data values (when they appear as constants) using Data::Dumper.
4307 Without this option, B::Deparse will use some simple routines of its
4308 own for the same purpose. Currently, Data::Dumper is better for some
4309 kinds of data (such as complex structures with sharing and
4310 self-reference) while the built-in routines are better for others
4311 (such as odd floating-point values).
4315 Normally, B::Deparse deparses the main code of a program, and all the subs
4316 defined in the same file. To include subs defined in other files, pass the
4317 B<-f> option with the filename. You can pass the B<-f> option several times, to
4318 include more than one secondary file. (Most of the time you don't want to
4319 use it at all.) You can also use this option to include subs which are
4320 defined in the scope of a B<#line> directive with two parameters.
4324 Add '#line' declarations to the output based on the line and file
4325 locations of the original code.
4329 Print extra parentheses. Without this option, B::Deparse includes
4330 parentheses in its output only when they are needed, based on the
4331 structure of your program. With B<-p>, it uses parentheses (almost)
4332 whenever they would be legal. This can be useful if you are used to
4333 LISP, or if you want to see how perl parses your input. If you say
4335 if ($var & 0x7f == 65) {print "Gimme an A!"}
4336 print ($which ? $a : $b), "\n";
4337 $name = $ENV{USER} or "Bob";
4339 C<B::Deparse,-p> will print
4342 print('Gimme an A!')
4344 (print(($which ? $a : $b)), '???');
4345 (($name = $ENV{'USER'}) or '???')
4347 which probably isn't what you intended (the C<'???'> is a sign that
4348 perl optimized away a constant value).
4352 Disable prototype checking. With this option, all function calls are
4353 deparsed as if no prototype was defined for them. In other words,
4355 perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
4364 making clear how the parameters are actually passed to C<foo>.
4368 Expand double-quoted strings into the corresponding combinations of
4369 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
4372 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
4376 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
4377 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
4379 Note that the expanded form represents the way perl handles such
4380 constructions internally -- this option actually turns off the reverse
4381 translation that B::Deparse usually does. On the other hand, note that
4382 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
4383 of $y into a string before doing the assignment.
4385 =item B<-s>I<LETTERS>
4387 Tweak the style of B::Deparse's output. The letters should follow
4388 directly after the 's', with no space or punctuation. The following
4389 options are available:
4395 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
4412 The default is not to cuddle.
4416 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
4420 Use tabs for each 8 columns of indent. The default is to use only spaces.
4421 For instance, if the style options are B<-si4T>, a line that's indented
4422 3 times will be preceded by one tab and four spaces; if the options were
4423 B<-si8T>, the same line would be preceded by three tabs.
4425 =item B<v>I<STRING>B<.>
4427 Print I<STRING> for the value of a constant that can't be determined
4428 because it was optimized away (mnemonic: this happens when a constant
4429 is used in B<v>oid context). The end of the string is marked by a period.
4430 The string should be a valid perl expression, generally a constant.
4431 Note that unless it's a number, it probably needs to be quoted, and on
4432 a command line quotes need to be protected from the shell. Some
4433 conventional values include 0, 1, 42, '', 'foo', and
4434 'Useless use of constant omitted' (which may need to be
4435 B<-sv"'Useless use of constant omitted'.">
4436 or something similar depending on your shell). The default is '???'.
4437 If you're using B::Deparse on a module or other file that's require'd,
4438 you shouldn't use a value that evaluates to false, since the customary
4439 true constant at the end of a module will be in void context when the
4440 file is compiled as a main program.
4446 Expand conventional syntax constructions into equivalent ones that expose
4447 their internal operation. I<LEVEL> should be a digit, with higher values
4448 meaning more expansion. As with B<-q>, this actually involves turning off
4449 special cases in B::Deparse's normal operations.
4451 If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
4452 while loops with continue blocks; for instance
4454 for ($i = 0; $i < 10; ++$i) {
4467 Note that in a few cases this translation can't be perfectly carried back
4468 into the source code -- if the loop's initializer declares a my variable,
4469 for instance, it won't have the correct scope outside of the loop.
4471 If I<LEVEL> is at least 5, C<use> declarations will be translated into
4472 C<BEGIN> blocks containing calls to C<require> and C<import>; for
4482 'strict'->import('refs')
4486 If I<LEVEL> is at least 7, C<if> statements will be translated into
4487 equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
4489 print 'hi' if $nice;
4501 $nice and print 'hi';
4502 $nice and do { print 'hi' };
4503 $nice ? do { print 'hi' } : do { print 'bye' };
4505 Long sequences of elsifs will turn into nested ternary operators, which
4506 B::Deparse doesn't know how to indent nicely.
4510 =head1 USING B::Deparse AS A MODULE
4515 $deparse = B::Deparse->new("-p", "-sC");
4516 $body = $deparse->coderef2text(\&func);
4517 eval "sub func $body"; # the inverse operation
4521 B::Deparse can also be used on a sub-by-sub basis from other perl
4526 $deparse = B::Deparse->new(OPTIONS)
4528 Create an object to store the state of a deparsing operation and any
4529 options. The options are the same as those that can be given on the
4530 command line (see L</OPTIONS>); options that are separated by commas
4531 after B<-MO=Deparse> should be given as separate strings. Some
4532 options, like B<-u>, don't make sense for a single subroutine, so
4535 =head2 ambient_pragmas
4537 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
4539 The compilation of a subroutine can be affected by a few compiler
4540 directives, B<pragmas>. These are:
4554 Assigning to the special variable $[
4574 Ordinarily, if you use B::Deparse on a subroutine which has
4575 been compiled in the presence of one or more of these pragmas,
4576 the output will include statements to turn on the appropriate
4577 directives. So if you then compile the code returned by coderef2text,
4578 it will behave the same way as the subroutine which you deparsed.
4580 However, you may know that you intend to use the results in a
4581 particular context, where some pragmas are already in scope. In
4582 this case, you use the B<ambient_pragmas> method to describe the
4583 assumptions you wish to make.
4585 Not all of the options currently have any useful effect. See
4586 L</BUGS> for more details.
4588 The parameters it accepts are:
4594 Takes a string, possibly containing several values separated
4595 by whitespace. The special values "all" and "none" mean what you'd
4598 $deparse->ambient_pragmas(strict => 'subs refs');
4602 Takes a number, the value of the array base $[.
4610 If the value is true, then the appropriate pragma is assumed to
4611 be in the ambient scope, otherwise not.
4615 Takes a string, possibly containing a whitespace-separated list of
4616 values. The values "all" and "none" are special. It's also permissible
4617 to pass an array reference here.
4619 $deparser->ambient_pragmas(re => 'eval');
4624 Takes a string, possibly containing a whitespace-separated list of
4625 values. The values "all" and "none" are special, again. It's also
4626 permissible to pass an array reference here.
4628 $deparser->ambient_pragmas(warnings => [qw[void io]]);
4630 If one of the values is the string "FATAL", then all the warnings
4631 in that list will be considered fatal, just as with the B<warnings>
4632 pragma itself. Should you need to specify that some warnings are
4633 fatal, and others are merely enabled, you can pass the B<warnings>
4636 $deparser->ambient_pragmas(
4638 warnings => [FATAL => qw/void io/],
4641 See L<perllexwarn> for more information about lexical warnings.
4647 These two parameters are used to specify the ambient pragmas in
4648 the format used by the special variables $^H and ${^WARNING_BITS}.
4650 They exist principally so that you can write code like:
4652 { my ($hint_bits, $warning_bits);
4653 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
4654 $deparser->ambient_pragmas (
4655 hint_bits => $hint_bits,
4656 warning_bits => $warning_bits,
4660 which specifies that the ambient pragmas are exactly those which
4661 are in scope at the point of calling.
4667 $body = $deparse->coderef2text(\&func)
4668 $body = $deparse->coderef2text(sub ($$) { ... })
4670 Return source code for the body of a subroutine (a block, optionally
4671 preceded by a prototype in parens), given a reference to the
4672 sub. Because a subroutine can have no names, or more than one name,
4673 this method doesn't return a complete subroutine definition -- if you
4674 want to eval the result, you should prepend "sub subname ", or "sub "
4675 for an anonymous function constructor. Unless the sub was defined in
4676 the main:: package, the code will include a package declaration.
4684 The only pragmas to be completely supported are: C<use warnings>,
4685 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
4686 behaves like a pragma, is also supported.)
4688 Excepting those listed above, we're currently unable to guarantee that
4689 B::Deparse will produce a pragma at the correct point in the program.
4690 (Specifically, pragmas at the beginning of a block often appear right
4691 before the start of the block instead.)
4692 Since the effects of pragmas are often lexically scoped, this can mean
4693 that the pragma holds sway over a different portion of the program
4694 than in the input file.
4698 In fact, the above is a specific instance of a more general problem:
4699 we can't guarantee to produce BEGIN blocks or C<use> declarations in
4700 exactly the right place. So if you use a module which affects compilation
4701 (such as by over-riding keywords, overloading constants or whatever)
4702 then the output code might not work as intended.
4704 This is the most serious outstanding problem, and will require some help
4705 from the Perl core to fix.
4709 If a keyword is over-ridden, and your program explicitly calls
4710 the built-in version by using CORE::keyword, the output of B::Deparse
4711 will not reflect this. If you run the resulting code, it will call
4712 the over-ridden version rather than the built-in one. (Maybe there
4713 should be an option to B<always> print keyword calls as C<CORE::name>.)
4717 Some constants don't print correctly either with or without B<-d>.
4718 For instance, neither B::Deparse nor Data::Dumper know how to print
4719 dual-valued scalars correctly, as in:
4721 use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
4725 An input file that uses source filtering probably won't be deparsed into
4726 runnable code, because it will still include the B<use> declaration
4727 for the source filtering module, even though the code that is
4728 produced is already ordinary Perl which shouldn't be filtered again.
4732 Optimised away statements are rendered as '???'. This includes statements that
4733 have a compile-time side-effect, such as the obscure
4737 which is not, consequently, deparsed correctly.
4741 Lexical (my) variables declared in scopes external to a subroutine
4742 appear in code2ref output text as package variables. This is a tricky
4743 problem, as perl has no native facility for refering to a lexical variable
4744 defined within a different scope, although L<PadWalker> is a good start.
4748 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4754 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
4755 by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
4756 Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
4757 Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael