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
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
19 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
21 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
22 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
23 ($] < 5.008004 ? () : 'OPpSORT_INPLACE'),
24 ($] < 5.008006 ? () : qw(OPpSORT_DESCEND OPpITER_REVERSED)),
25 ($] < 5.008009 ? () : qw(OPpCONST_NOVER OPpPAD_STATE)),
26 ($] < 5.009 ? 'PMf_SKIPWHITE' : qw(RXf_SKIPWHITE)),
27 ($] < 5.011 ? 'CVf_LOCKED' : 'OPpREVERSE_INPLACE'),
28 ($] < 5.013 ? () : 'PMf_NONDESTRUCT');
31 use vars qw/$AUTOLOAD/;
35 # Easiest way to keep this code portable between version looks to
36 # be to fake up a dummy constant that will never actually be true.
37 foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
38 OPpPAD_STATE RXf_SKIPWHITE CVf_LOCKED OPpREVERSE_INPLACE
41 *{$_} = sub () {0} unless *{$_}{CODE};
45 # Changes between 0.50 and 0.51:
46 # - fixed nulled leave with live enter in sort { }
47 # - fixed reference constants (\"str")
48 # - handle empty programs gracefully
49 # - handle infinite loops (for (;;) {}, while (1) {})
50 # - differentiate between `for my $x ...' and `my $x; for $x ...'
51 # - various minor cleanups
52 # - moved globals into an object
53 # - added `-u', like B::C
54 # - package declarations using cop_stash
55 # - subs, formats and code sorted by cop_seq
56 # Changes between 0.51 and 0.52:
57 # - added pp_threadsv (special variables under USE_5005THREADS)
58 # - added documentation
59 # Changes between 0.52 and 0.53:
60 # - many changes adding precedence contexts and associativity
61 # - added `-p' and `-s' output style options
62 # - various other minor fixes
63 # Changes between 0.53 and 0.54:
64 # - added support for new `for (1..100)' optimization,
66 # Changes between 0.54 and 0.55:
67 # - added support for new qr// construct
68 # - added support for new pp_regcreset OP
69 # Changes between 0.55 and 0.56:
70 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
71 # - fixed $# on non-lexicals broken in last big rewrite
72 # - added temporary fix for change in opcode of OP_STRINGIFY
73 # - fixed problem in 0.54's for() patch in `for (@ary)'
74 # - fixed precedence in conditional of ?:
75 # - tweaked list paren elimination in `my($x) = @_'
76 # - made continue-block detection trickier wrt. null ops
77 # - fixed various prototype problems in pp_entersub
78 # - added support for sub prototypes that never get GVs
79 # - added unquoting for special filehandle first arg in truncate
80 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
81 # - added semicolons at the ends of blocks
82 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
83 # Changes between 0.56 and 0.561:
84 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
85 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
86 # Changes between 0.561 and 0.57:
87 # - stylistic changes to symbolic constant stuff
88 # - handled scope in s///e replacement code
89 # - added unquote option for expanding "" into concats, etc.
90 # - split method and proto parts of pp_entersub into separate functions
91 # - various minor cleanups
93 # - added parens in \&foo (patch by Albert Dvornik)
94 # Changes between 0.57 and 0.58:
95 # - fixed `0' statements that weren't being printed
96 # - added methods for use from other programs
97 # (based on patches from James Duncan and Hugo van der Sanden)
98 # - added -si and -sT to control indenting (also based on a patch from Hugo)
99 # - added -sv to print something else instead of '???'
100 # - preliminary version of utf8 tr/// handling
101 # Changes after 0.58:
102 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
103 # - added support for Hugo's new OP_SETSTATE (like nextstate)
104 # Changes between 0.58 and 0.59
105 # - added support for Chip's OP_METHOD_NAMED
106 # - added support for Ilya's OPpTARGET_MY optimization
107 # - elided arrows before `()' subscripts when possible
108 # Changes between 0.59 and 0.60
109 # - support for method attributes was added
110 # - some warnings fixed
111 # - separate recognition of constant subs
112 # - rewrote continue block handling, now recognizing for loops
113 # - added more control of expanding control structures
114 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
116 # - support for pragmas and 'use'
117 # - support for the little-used $[ variable
118 # - support for __DATA__ sections
120 # - BEGIN, CHECK, INIT and END blocks
121 # - scoping of subroutine declarations fixed
122 # - compile-time output from the input program can be suppressed, so that the
123 # output is just the deparsed code. (a change to O.pm in fact)
124 # - our() declarations
125 # - *all* the known bugs are now listed in the BUGS section
126 # - comprehensive test mechanism (TEST -deparse)
127 # Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
130 # - support for command-line switches (-l, -0, etc.)
131 # Changes between 0.63 and 0.64
132 # - support for //, CHECK blocks, and assertions
133 # - improved handling of foreach loops and lexicals
134 # - option to use Data::Dumper for constants
136 # - discovered lots more bugs not yet fixed
140 # Changes between 0.72 and 0.73
141 # - support new switch constructs
144 # (See also BUGS section at the end of this file)
146 # - finish tr/// changes
147 # - add option for even more parens (generalize \&foo change)
148 # - left/right context
149 # - copy comments (look at real text with $^P?)
150 # - avoid semis in one-statement blocks
151 # - associativity of &&=, ||=, ?:
152 # - ',' => '=>' (auto-unquote?)
153 # - break long lines ("\r" as discretionary break?)
154 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
155 # - more style options: brace style, hex vs. octal, quotes, ...
156 # - print big ints as hex/octal instead of decimal (heuristic?)
157 # - handle `my $x if 0'?
158 # - version using op_next instead of op_first/sibling?
159 # - avoid string copies (pass arrays, one big join?)
162 # Current test.deparse failures
163 # comp/hints 6 - location of BEGIN blocks wrt. block openings
164 # run/switchI 1 - missing -I switches entirely
165 # perl -Ifoo -e 'print @INC'
166 # op/caller 2 - warning mask propagates backwards before warnings::register
167 # 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
168 # op/getpid 2 - can't assign to shared my() declaration (threads only)
169 # 'my $x : shared = 5'
170 # op/override 7 - parens on overridden require change v-string interpretation
171 # 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
172 # c.f. 'BEGIN { *f = sub {0} }; f 2'
173 # op/pat 774 - losing Unicode-ness of Latin1-only strings
174 # 'use charnames ":short"; $x="\N{latin:a with acute}"'
175 # op/recurse 12 - missing parens on recursive call makes it look like method
177 # op/subst 90 - inconsistent handling of utf8 under "use utf8"
178 # op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
179 # op/tiehandle compile - "use strict" deparsed in the wrong place
181 # ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
182 # ext/Data/Dumper/t/dumper compile
183 # ext/DB_file/several
185 # ext/Ernno/Errno warnings
186 # ext/IO/lib/IO/t/io_sel 23
187 # ext/PerlIO/t/encoding compile
188 # ext/POSIX/t/posix 6
189 # ext/Socket/Socket 8
190 # ext/Storable/t/croak compile
191 # lib/Attribute/Handlers/t/multi compile
192 # lib/bignum/ several
196 # lib/ExtUtils/t/bytes 4
197 # lib/File/DosGlob compile
198 # lib/Filter/Simple/t/data 1
199 # lib/Math/BigInt/t/constant 1
200 # lib/Net/t/config Deparse-warning
201 # lib/overload compile
202 # lib/Switch/ several
204 # lib/Test/Simple several
206 # lib/Tie/File/t/29_downcopy 5
209 # Object fields (were globals):
212 # (local($a), local($b)) and local($a, $b) have the same internal
213 # representation but the short form looks better. We notice we can
214 # use a large-scale local when checking the list, but need to prevent
215 # individual locals too. This hash holds the addresses of OPs that
216 # have already had their local-ness accounted for. The same thing
220 # CV for current sub (or main program) being deparsed
223 # Cached hash of lexical variables for curcv: keys are names,
224 # each value is an array of pairs, indicating the cop_seq of scopes
225 # in which a var of that name is valid.
228 # COP for statement being deparsed
231 # name of the current package for deparsed code
234 # array of [cop_seq, CV, is_format?] for subs and formats we still
238 # as above, but [name, prototype] for subs that never got a GV
240 # subs_done, forms_done:
241 # keys are addresses of GVs for subs and formats we've already
242 # deparsed (or at least put into subs_todo)
245 # keys are names of subs for which we've printed declarations.
246 # That means we can omit parentheses from the arguments.
249 # Keeps track of fully qualified names of all deparsed subs.
254 # cuddle: ` ' or `\n', depending on -sC
259 # A little explanation of how precedence contexts and associativity
262 # deparse() calls each per-op subroutine with an argument $cx (short
263 # for context, but not the same as the cx* in the perl core), which is
264 # a number describing the op's parents in terms of precedence, whether
265 # they're inside an expression or at statement level, etc. (see
266 # chart below). When ops with children call deparse on them, they pass
267 # along their precedence. Fractional values are used to implement
268 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
269 # parentheses hacks. The major disadvantage of this scheme is that
270 # it doesn't know about right sides and left sides, so say if you
271 # assign a listop to a variable, it can't tell it's allowed to leave
272 # the parens off the listop.
275 # 26 [TODO] inside interpolation context ("")
276 # 25 left terms and list operators (leftward)
280 # 21 right ! ~ \ and unary + and -
285 # 16 nonassoc named unary operators
286 # 15 nonassoc < > <= >= lt gt le ge
287 # 14 nonassoc == != <=> eq ne cmp
294 # 7 right = += -= *= etc.
296 # 5 nonassoc list operators (rightward)
300 # 1 statement modifiers
301 # 0.5 statements, but still print scopes as do { ... }
304 # Nonprinting characters with special meaning:
305 # \cS - steal parens (see maybe_parens_unop)
306 # \n - newline and indent
307 # \t - increase indent
308 # \b - decrease indent (`outdent')
309 # \f - flush left (no indent)
310 # \cK - kill following semicolon, if any
314 return class($op) eq "NULL";
319 my($cv, $is_form) = @_;
320 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
322 if ($cv->OUTSIDE_SEQ) {
323 $seq = $cv->OUTSIDE_SEQ;
324 } elsif (!null($cv->START) and is_state($cv->START)) {
325 $seq = $cv->START->cop_seq;
329 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
330 unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
331 $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
337 my $ent = shift @{$self->{'subs_todo'}};
340 my $name = $self->gv_name($gv);
342 return "format $name =\n"
343 . $self->deparse_format($ent->[1]). "\n";
345 $self->{'subs_declared'}{$name} = 1;
346 if ($name eq "BEGIN") {
347 my $use_dec = $self->begin_is_use($cv);
348 if (defined ($use_dec) and $self->{'expand'} < 5) {
349 return () if 0 == length($use_dec);
354 if ($self->{'linenums'}) {
355 my $line = $gv->LINE;
356 my $file = $gv->FILE;
357 $l = "\n\f#line $line \"$file\"\n";
360 if (class($cv->STASH) ne "SPECIAL") {
361 my $stash = $cv->STASH->NAME;
362 if ($stash ne $self->{'curstash'}) {
363 $p = "package $stash;\n";
364 $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
365 $self->{'curstash'} = $stash;
367 $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
369 return "${p}${l}sub $name " . $self->deparse_sub($cv);
373 # Return a "use" declaration for this BEGIN block, if appropriate
375 my ($self, $cv) = @_;
376 my $root = $cv->ROOT;
377 local @$self{qw'curcv curcvlex'} = ($cv);
379 #B::walkoptree($cv->ROOT, "debug");
380 my $lineseq = $root->first;
381 return if $lineseq->name ne "lineseq";
383 my $req_op = $lineseq->first->sibling;
384 return if $req_op->name ne "require";
387 if ($req_op->first->private & OPpCONST_BARE) {
388 # Actually it should always be a bareword
389 $module = $self->const_sv($req_op->first)->PV;
390 $module =~ s[/][::]g;
394 $module = $self->const($self->const_sv($req_op->first), 6);
398 my $version_op = $req_op->sibling;
399 return if class($version_op) eq "NULL";
400 if ($version_op->name eq "lineseq") {
401 # We have a version parameter; skip nextstate & pushmark
402 my $constop = $version_op->first->next->next;
404 return unless $self->const_sv($constop)->PV eq $module;
405 $constop = $constop->sibling;
406 $version = $self->const_sv($constop);
407 if (class($version) eq "IV") {
408 $version = $version->int_value;
409 } elsif (class($version) eq "NV") {
410 $version = $version->NV;
411 } elsif (class($version) ne "PVMG") {
412 # Includes PVIV and PVNV
413 $version = $version->PV;
415 # version specified as a v-string
416 $version = 'v'.join '.', map ord, split //, $version->PV;
418 $constop = $constop->sibling;
419 return if $constop->name ne "method_named";
420 return if $self->const_sv($constop)->PV ne "VERSION";
423 $lineseq = $version_op->sibling;
424 return if $lineseq->name ne "lineseq";
425 my $entersub = $lineseq->first->sibling;
426 if ($entersub->name eq "stub") {
427 return "use $module $version ();\n" if defined $version;
428 return "use $module ();\n";
430 return if $entersub->name ne "entersub";
432 # See if there are import arguments
435 my $svop = $entersub->first->sibling; # Skip over pushmark
436 return unless $self->const_sv($svop)->PV eq $module;
438 # Pull out the arguments
439 for ($svop=$svop->sibling; $svop->name ne "method_named";
440 $svop = $svop->sibling) {
441 $args .= ", " if length($args);
442 $args .= $self->deparse($svop, 6);
446 my $method_named = $svop;
447 return if $method_named->name ne "method_named";
448 my $method_name = $self->const_sv($method_named)->PV;
450 if ($method_name eq "unimport") {
454 # Certain pragmas are dealt with using hint bits,
455 # so we ignore them here
456 if ($module eq 'strict' || $module eq 'integer'
457 || $module eq 'bytes' || $module eq 'warnings'
458 || $module eq 'feature') {
462 if (defined $version && length $args) {
463 return "$use $module $version ($args);\n";
464 } elsif (defined $version) {
465 return "$use $module $version;\n";
466 } elsif (length $args) {
467 return "$use $module ($args);\n";
469 return "$use $module;\n";
474 my ($self, $pack) = @_;
476 if (!defined $pack) {
481 $pack =~ s/(::)?$/::/;
485 my %stash = svref_2object($stash)->ARRAY;
486 while (my ($key, $val) = each %stash) {
487 my $class = class($val);
488 if ($class eq "PV") {
489 # Just a prototype. As an ugly but fairly effective way
490 # to find out if it belongs here is to see if the AUTOLOAD
491 # (if any) for the stash was defined in one of our files.
492 my $A = $stash{"AUTOLOAD"};
493 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
494 && class($A->CV) eq "CV") {
496 next unless $AF eq $0 || exists $self->{'files'}{$AF};
498 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
499 } elsif ($class eq "IV" && !($val->FLAGS & SVf_ROK)) {
500 # Just a name. As above.
501 # But skip proxy constant subroutines, as some form of perl-space
502 # visible code must have created them, be it a use statement, or
503 # some direct symbol-table manipulation code that we will Deparse
504 my $A = $stash{"AUTOLOAD"};
505 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
506 && class($A->CV) eq "CV") {
508 next unless $AF eq $0 || exists $self->{'files'}{$AF};
510 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
511 } elsif ($class eq "GV") {
512 if (class(my $cv = $val->CV) ne "SPECIAL") {
513 next if $self->{'subs_done'}{$$val}++;
514 next if $$val != ${$cv->GV}; # Ignore imposters
517 if (class(my $cv = $val->FORM) ne "SPECIAL") {
518 next if $self->{'forms_done'}{$$val}++;
519 next if $$val != ${$cv->GV}; # Ignore imposters
522 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
523 $self->stash_subs($pack . $key)
524 unless $pack eq '' && $key eq 'main::';
525 # avoid infinite recursion
535 foreach $ar (@{$self->{'protos_todo'}}) {
536 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
537 push @ret, "sub " . $ar->[0] . "$proto;\n";
539 delete $self->{'protos_todo'};
547 while (length($opt = substr($opts, 0, 1))) {
549 $self->{'cuddle'} = " ";
550 $opts = substr($opts, 1);
551 } elsif ($opt eq "i") {
552 $opts =~ s/^i(\d+)//;
553 $self->{'indent_size'} = $1;
554 } elsif ($opt eq "T") {
555 $self->{'use_tabs'} = 1;
556 $opts = substr($opts, 1);
557 } elsif ($opt eq "v") {
558 $opts =~ s/^v([^.]*)(.|$)//;
559 $self->{'ex_const'} = $1;
566 my $self = bless {}, $class;
567 $self->{'cuddle'} = "\n";
568 $self->{'curcop'} = undef;
569 $self->{'curstash'} = "main";
570 $self->{'ex_const'} = "'???'";
571 $self->{'expand'} = 0;
572 $self->{'files'} = {};
573 $self->{'indent_size'} = 4;
574 $self->{'linenums'} = 0;
575 $self->{'parens'} = 0;
576 $self->{'subs_todo'} = [];
577 $self->{'unquote'} = 0;
578 $self->{'use_dumper'} = 0;
579 $self->{'use_tabs'} = 0;
581 $self->{'ambient_arybase'} = 0;
582 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
583 $self->{'ambient_hints'} = 0;
584 $self->{'ambient_hinthash'} = undef;
587 while (my $arg = shift @_) {
589 $self->{'use_dumper'} = 1;
590 require Data::Dumper;
591 } elsif ($arg =~ /^-f(.*)/) {
592 $self->{'files'}{$1} = 1;
593 } elsif ($arg eq "-l") {
594 $self->{'linenums'} = 1;
595 } elsif ($arg eq "-p") {
596 $self->{'parens'} = 1;
597 } elsif ($arg eq "-P") {
598 $self->{'noproto'} = 1;
599 } elsif ($arg eq "-q") {
600 $self->{'unquote'} = 1;
601 } elsif (substr($arg, 0, 2) eq "-s") {
602 $self->style_opts(substr $arg, 2);
603 } elsif ($arg =~ /^-x(\d)$/) {
604 $self->{'expand'} = $1;
611 # Mask out the bits that L<warnings::register> uses
614 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
621 # Initialise the contextual information, either from
622 # defaults provided with the ambient_pragmas method,
623 # or from perl's own defaults otherwise.
627 $self->{'arybase'} = $self->{'ambient_arybase'};
628 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
629 ? $self->{'ambient_warnings'} & WARN_MASK
631 $self->{'hints'} = $self->{'ambient_hints'};
632 $self->{'hints'} &= 0xFF if $] < 5.009;
633 $self->{'hinthash'} = $self->{'ambient_hinthash'};
635 # also a convenient place to clear out subs_declared
636 delete $self->{'subs_declared'};
642 my $self = B::Deparse->new(@args);
643 # First deparse command-line args
644 if (defined $^I) { # deparse -i
645 print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
647 if ($^W) { # deparse -w
648 print qq(BEGIN { \$^W = $^W; }\n);
650 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
651 my $fs = perlstring($/) || 'undef';
652 my $bs = perlstring($O::savebackslash) || 'undef';
653 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
655 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
656 my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
657 ? B::unitcheck_av->ARRAY
659 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
660 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
661 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
662 for my $block (@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
663 $self->todo($block, 0);
666 local($SIG{"__DIE__"}) =
668 if ($self->{'curcop'}) {
669 my $cop = $self->{'curcop'};
670 my($line, $file) = ($cop->line, $cop->file);
671 print STDERR "While deparsing $file near line $line,\n";
674 $self->{'curcv'} = main_cv;
675 $self->{'curcvlex'} = undef;
676 print $self->print_protos;
677 @{$self->{'subs_todo'}} =
678 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
679 print $self->indent($self->deparse_root(main_root)), "\n"
680 unless null main_root;
682 while (scalar(@{$self->{'subs_todo'}})) {
683 push @text, $self->next_todo;
685 print $self->indent(join("", @text)), "\n" if @text;
687 # Print __DATA__ section, if necessary
689 my $laststash = defined $self->{'curcop'}
690 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
691 if (defined *{$laststash."::DATA"}{IO}) {
692 print "package $laststash;\n"
693 unless $laststash eq $self->{'curstash'};
695 print readline(*{$laststash."::DATA"});
703 croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
706 return $self->indent($self->deparse_sub(svref_2object($sub)));
709 sub ambient_pragmas {
711 my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
717 if ($name eq 'strict') {
720 if ($val eq 'none') {
721 $hint_bits &= ~strict::bits(qw/refs subs vars/);
727 @names = qw/refs subs vars/;
733 @names = split' ', $val;
735 $hint_bits |= strict::bits(@names);
738 elsif ($name eq '$[') {
742 elsif ($name eq 'integer'
744 || $name eq 'utf8') {
747 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
750 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
754 elsif ($name eq 're') {
756 if ($val eq 'none') {
757 $hint_bits &= ~re::bits(qw/taint eval/);
763 @names = qw/taint eval/;
769 @names = split' ',$val;
771 $hint_bits |= re::bits(@names);
774 elsif ($name eq 'warnings') {
775 if ($val eq 'none') {
776 $warning_bits = $warnings::NONE;
785 @names = split/\s+/, $val;
788 $warning_bits = $warnings::NONE if !defined ($warning_bits);
789 $warning_bits |= warnings::bits(@names);
792 elsif ($name eq 'warning_bits') {
793 $warning_bits = $val;
796 elsif ($name eq 'hint_bits') {
800 elsif ($name eq '%^H') {
805 croak "Unknown pragma type: $name";
809 croak "The ambient_pragmas method expects an even number of args";
812 $self->{'ambient_arybase'} = $arybase;
813 $self->{'ambient_warnings'} = $warning_bits;
814 $self->{'ambient_hints'} = $hint_bits;
815 $self->{'ambient_hinthash'} = $hinthash;
818 # This method is the inner loop, so try to keep it simple
823 Carp::confess("Null op in deparse") if !defined($op)
824 || class($op) eq "NULL";
825 my $meth = "pp_" . $op->name;
826 return $self->$meth($op, $cx);
832 my @lines = split(/\n/, $txt);
837 my $cmd = substr($line, 0, 1);
838 if ($cmd eq "\t" or $cmd eq "\b") {
839 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
840 if ($self->{'use_tabs'}) {
841 $leader = "\t" x ($level / 8) . " " x ($level % 8);
843 $leader = " " x $level;
845 $line = substr($line, 1);
847 if (substr($line, 0, 1) eq "\f") {
848 $line = substr($line, 1); # no indent
850 $line = $leader . $line;
854 return join("\n", @lines);
861 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
862 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
863 local $self->{'curcop'} = $self->{'curcop'};
864 if ($cv->FLAGS & SVf_POK) {
865 $proto = "(". $cv->PV . ") ";
867 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
869 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
870 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
871 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
874 local($self->{'curcv'}) = $cv;
875 local($self->{'curcvlex'});
876 local(@$self{qw'curstash warnings hints hinthash'})
877 = @$self{qw'curstash warnings hints hinthash'};
879 if (not null $cv->ROOT) {
880 my $lineseq = $cv->ROOT->first;
881 if ($lineseq->name eq "lineseq") {
883 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
886 $body = $self->lineseq(undef, @ops).";";
887 my $scope_en = $self->find_scope_en($lineseq);
888 if (defined $scope_en) {
889 my $subs = join"", $self->seq_subs($scope_en);
890 $body .= ";\n$subs" if length($subs);
894 $body = $self->deparse($cv->ROOT->first, 0);
898 my $sv = $cv->const_sv;
900 # uh-oh. inlinable sub... format it differently
901 return $proto . "{ " . $self->const($sv, 0) . " }\n";
902 } else { # XSUB? (or just a declaration)
906 return $proto ."{\n\t$body\n\b}" ."\n";
913 local($self->{'curcv'}) = $form;
914 local($self->{'curcvlex'});
915 local($self->{'in_format'}) = 1;
916 local(@$self{qw'curstash warnings hints hinthash'})
917 = @$self{qw'curstash warnings hints hinthash'};
918 my $op = $form->ROOT;
920 return "\f." if $op->first->name eq 'stub'
921 || $op->first->name eq 'nextstate';
922 $op = $op->first->first; # skip leavewrite, lineseq
923 while (not null $op) {
924 $op = $op->sibling; # skip nextstate
926 $kid = $op->first->sibling; # skip pushmark
927 push @text, "\f".$self->const_sv($kid)->PV;
928 $kid = $kid->sibling;
929 for (; not null $kid; $kid = $kid->sibling) {
930 push @exprs, $self->deparse($kid, 0);
932 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
935 return join("", @text) . "\f.";
940 return $op->name eq "leave" || $op->name eq "scope"
941 || $op->name eq "lineseq"
942 || ($op->name eq "null" && class($op) eq "UNOP"
943 && (is_scope($op->first) || $op->first->name eq "enter"));
947 my $name = $_[0]->name;
948 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
951 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
953 return (!null($op) and null($op->sibling)
954 and $op->name eq "null" and class($op) eq "UNOP"
955 and (($op->first->name =~ /^(and|or)$/
956 and $op->first->first->sibling->name eq "lineseq")
957 or ($op->first->name eq "lineseq"
958 and not null $op->first->first->sibling
959 and $op->first->first->sibling->name eq "unstack")
963 # Check if the op and its sibling are the initialization and the rest of a
964 # for (..;..;..) { ... } loop
967 # This OP might be almost anything, though it won't be a
968 # nextstate. (It's the initialization, so in the canonical case it
969 # will be an sassign.) The sibling is (old style) a lineseq whose
970 # first child is a nextstate and whose second is a leaveloop, or
971 # (new style) an unstack whose sibling is a leaveloop.
972 my $lseq = $op->sibling;
973 return 0 unless !is_state($op) and !null($lseq);
974 if ($lseq->name eq "lineseq") {
975 if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
976 && (my $sib = $lseq->first->sibling)) {
977 return (!null($sib) && $sib->name eq "leaveloop");
979 } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) {
980 my $sib = $lseq->sibling;
981 return $sib && !null($sib) && $sib->name eq "leaveloop";
988 return ($op->name eq "rv2sv" or
989 $op->name eq "padsv" or
990 $op->name eq "gv" or # only in array/hash constructs
991 $op->flags & OPf_KIDS && !null($op->first)
992 && $op->first->name eq "gvsv");
997 my($text, $cx, $prec) = @_;
998 if ($prec < $cx # unary ops nest just fine
999 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
1000 or $self->{'parens'})
1003 # In a unop, let parent reuse our parens; see maybe_parens_unop
1004 $text = "\cS" . $text if $cx == 16;
1011 # same as above, but get around the `if it looks like a function' rule
1012 sub maybe_parens_unop {
1014 my($name, $kid, $cx) = @_;
1015 if ($cx > 16 or $self->{'parens'}) {
1016 $kid = $self->deparse($kid, 1);
1017 if ($name eq "umask" && $kid =~ /^\d+$/) {
1018 $kid = sprintf("%#o", $kid);
1020 return "$name($kid)";
1022 $kid = $self->deparse($kid, 16);
1023 if ($name eq "umask" && $kid =~ /^\d+$/) {
1024 $kid = sprintf("%#o", $kid);
1026 if (substr($kid, 0, 1) eq "\cS") {
1028 return $name . substr($kid, 1);
1029 } elsif (substr($kid, 0, 1) eq "(") {
1030 # avoid looks-like-a-function trap with extra parens
1031 # (`+' can lead to ambiguities)
1032 return "$name(" . $kid . ")";
1034 return "$name $kid";
1039 sub maybe_parens_func {
1041 my($func, $text, $cx, $prec) = @_;
1042 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
1043 return "$func($text)";
1045 return "$func $text";
1051 my($op, $cx, $text) = @_;
1052 my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
1053 if ($op->private & (OPpLVAL_INTRO|$our_intro)
1054 and not $self->{'avoid_local'}{$$op}) {
1055 my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
1056 if( $our_local eq 'our' ) {
1057 if ( $text !~ /^\W(\w+::)*\w+\z/
1058 and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
1060 die "Unexpected our($text)\n";
1062 $text =~ s/(\w+::)+//;
1064 if (want_scalar($op)) {
1065 return "$our_local $text";
1067 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
1076 my($op, $cx, $func, @args) = @_;
1077 if ($op->private & OPpTARGET_MY) {
1078 my $var = $self->padname($op->targ);
1079 my $val = $func->($self, $op, 7, @args);
1080 return $self->maybe_parens("$var = $val", $cx, 7);
1082 return $func->($self, $op, $cx, @args);
1089 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
1094 my($op, $cx, $text) = @_;
1095 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
1096 my $my = $op->private & OPpPAD_STATE ? "state" : "my";
1097 if (want_scalar($op)) {
1100 return $self->maybe_parens_func($my, $text, $cx, 16);
1107 # The following OPs don't have functions:
1109 # pp_padany -- does not exist after parsing
1112 if ($AUTOLOAD =~ s/^.*::pp_//) {
1113 warn "unexpected OP_".uc $AUTOLOAD;
1116 die "Undefined subroutine $AUTOLOAD called";
1120 sub DESTROY {} # Do not AUTOLOAD
1122 # $root should be the op which represents the root of whatever
1123 # we're sequencing here. If it's undefined, then we don't append
1124 # any subroutine declarations to the deparsed ops, otherwise we
1125 # append appropriate declarations.
1127 my($self, $root, @ops) = @_;
1130 my $out_cop = $self->{'curcop'};
1131 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1133 if (defined $root) {
1134 $limit_seq = $out_seq;
1136 $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1137 $limit_seq = $nseq if !defined($limit_seq)
1138 or defined($nseq) && $nseq < $limit_seq;
1140 $limit_seq = $self->{'limit_seq'}
1141 if defined($self->{'limit_seq'})
1142 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1143 local $self->{'limit_seq'} = $limit_seq;
1145 $self->walk_lineseq($root, \@ops,
1146 sub { push @exprs, $_[0]} );
1148 my $body = join(";\n", grep {length} @exprs);
1150 if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1151 $subs = join "\n", $self->seq_subs($limit_seq);
1153 return join(";\n", grep {length} $body, $subs);
1157 my($real_block, $self, $op, $cx) = @_;
1161 local(@$self{qw'curstash warnings hints hinthash'})
1162 = @$self{qw'curstash warnings hints hinthash'} if $real_block;
1164 $kid = $op->first->sibling; # skip enter
1165 if (is_miniwhile($kid)) {
1166 my $top = $kid->first;
1167 my $name = $top->name;
1168 if ($name eq "and") {
1170 } elsif ($name eq "or") {
1172 } else { # no conditional -> while 1 or until 0
1173 return $self->deparse($top->first, 1) . " while 1";
1175 my $cond = $top->first;
1176 my $body = $cond->sibling->first; # skip lineseq
1177 $cond = $self->deparse($cond, 1);
1178 $body = $self->deparse($body, 1);
1179 return "$body $name $cond";
1184 for (; !null($kid); $kid = $kid->sibling) {
1187 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
1188 return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
1190 my $lineseq = $self->lineseq($op, @kids);
1191 return (length ($lineseq) ? "$lineseq;" : "");
1195 sub pp_scope { scopeop(0, @_); }
1196 sub pp_lineseq { scopeop(0, @_); }
1197 sub pp_leave { scopeop(1, @_); }
1199 # This is a special case of scopeop and lineseq, for the case of the
1200 # main_root. The difference is that we print the output statements as
1201 # soon as we get them, for the sake of impatient users.
1205 local(@$self{qw'curstash warnings hints hinthash'})
1206 = @$self{qw'curstash warnings hints hinthash'};
1208 return if null $op->first; # Can happen, e.g., for Bytecode without -k
1209 for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
1212 $self->walk_lineseq($op, \@kids,
1213 sub { print $self->indent($_[0].';');
1214 print "\n" unless $_[1] == $#kids;
1219 my ($self, $op, $kids, $callback) = @_;
1221 for (my $i = 0; $i < @kids; $i++) {
1223 if (is_state $kids[$i]) {
1224 $expr = $self->deparse($kids[$i++], 0);
1226 $callback->($expr, $i);
1230 if (is_for_loop($kids[$i])) {
1231 $callback->($expr . $self->for_loop($kids[$i], 0),
1232 $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
1235 $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
1236 $expr =~ s/;\n?\z//;
1237 $callback->($expr, $i);
1241 # The BEGIN {} is used here because otherwise this code isn't executed
1242 # when you run B::Deparse on itself.
1244 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1245 "ENV", "ARGV", "ARGVOUT", "_"); }
1250 Carp::confess() unless ref($gv) eq "B::GV";
1251 my $stash = $gv->STASH->NAME;
1252 my $name = $gv->SAFENAME;
1253 if ($stash eq 'main' && $name =~ /^::/) {
1256 elsif (($stash eq 'main' && $globalnames{$name})
1257 or ($stash eq $self->{'curstash'} && !$globalnames{$name}
1258 && ($stash eq 'main' || $name !~ /::/))
1259 or $name =~ /^[^A-Za-z_:]/)
1263 $stash = $stash . "::";
1265 if ($name =~ /^(\^..|{)/) {
1266 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
1268 return $stash . $name;
1271 # Return the name to use for a stash variable.
1272 # If a lexical with the same name is in scope, it may need to be
1274 sub stash_variable {
1275 my ($self, $prefix, $name) = @_;
1277 return "$prefix$name" if $name =~ /::/;
1279 unless ($prefix eq '$' || $prefix eq '@' || #'
1280 $prefix eq '%' || $prefix eq '$#') {
1281 return "$prefix$name";
1284 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1285 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
1286 return "$prefix$name";
1290 my ($self, $name) = @_;
1291 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1293 return 0 if !defined($self->{'curcop'});
1294 my $seq = $self->{'curcop'}->cop_seq;
1295 return 0 if !exists $self->{'curcvlex'}{$name};
1296 for my $a (@{$self->{'curcvlex'}{$name}}) {
1297 my ($st, $en) = @$a;
1298 return 1 if $seq > $st && $seq <= $en;
1303 sub populate_curcvlex {
1305 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1306 my $padlist = $cv->PADLIST;
1307 # an undef CV still in lexical chain
1308 next if class($padlist) eq "SPECIAL";
1309 my @padlist = $padlist->ARRAY;
1310 my @ns = $padlist[0]->ARRAY;
1312 for (my $i=0; $i<@ns; ++$i) {
1313 next if class($ns[$i]) eq "SPECIAL";
1314 next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
1315 if (class($ns[$i]) eq "PV") {
1316 # Probably that pesky lexical @_
1319 my $name = $ns[$i]->PVX;
1320 my ($seq_st, $seq_en) =
1321 ($ns[$i]->FLAGS & SVf_FAKE)
1323 : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
1325 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1330 sub find_scope_st { ((find_scope(@_))[0]); }
1331 sub find_scope_en { ((find_scope(@_))[1]); }
1333 # Recurses down the tree, looking for pad variable introductions and COPs
1335 my ($self, $op, $scope_st, $scope_en) = @_;
1336 carp("Undefined op in find_scope") if !defined $op;
1337 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1340 while(my $op = shift @queue ) {
1341 for (my $o=$op->first; $$o; $o=$o->sibling) {
1342 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1343 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
1344 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
1345 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1346 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1347 return ($scope_st, $scope_en);
1349 elsif (is_state($o)) {
1350 my $c = $o->cop_seq;
1351 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1352 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1353 return ($scope_st, $scope_en);
1355 elsif ($o->flags & OPf_KIDS) {
1356 unshift (@queue, $o);
1361 return ($scope_st, $scope_en);
1364 # Returns a list of subs which should be inserted before the COP
1366 my ($self, $op, $out_seq) = @_;
1367 my $seq = $op->cop_seq;
1368 # If we have nephews, then our sequence number indicates
1369 # the cop_seq of the end of some sort of scope.
1370 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1371 and my $nseq = $self->find_scope_st($op->sibling) ) {
1374 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1375 return $self->seq_subs($seq);
1379 my ($self, $seq) = @_;
1381 #push @text, "# ($seq)\n";
1383 return "" if !defined $seq;
1384 while (scalar(@{$self->{'subs_todo'}})
1385 and $seq > $self->{'subs_todo'}[0][0]) {
1386 push @text, $self->next_todo;
1391 # Notice how subs and formats are inserted between statements here;
1392 # also $[ assignments and pragmas.
1396 $self->{'curcop'} = $op;
1398 push @text, $self->cop_subs($op);
1399 my $stash = $op->stashpv;
1400 if ($stash ne $self->{'curstash'}) {
1401 push @text, "package $stash;\n";
1402 $self->{'curstash'} = $stash;
1405 if ($self->{'arybase'} != $op->arybase) {
1406 push @text, '$[ = '. $op->arybase .";\n";
1407 $self->{'arybase'} = $op->arybase;
1410 my $warnings = $op->warnings;
1412 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1413 $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
1415 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1416 $warning_bits = $warnings::NONE;
1418 elsif ($warnings->isa("B::SPECIAL")) {
1419 $warning_bits = undef;
1422 $warning_bits = $warnings->PV & WARN_MASK;
1425 if (defined ($warning_bits) and
1426 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1427 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1428 $self->{'warnings'} = $warning_bits;
1431 my $hints = $] < 5.008009 ? $op->private : $op->hints;
1432 if ($self->{'hints'} != $hints) {
1433 push @text, declare_hints($self->{'hints'}, $hints);
1434 $self->{'hints'} = $hints;
1437 # hack to check that the hint hash hasn't changed
1439 "@{[sort %{$self->{'hinthash'} || {}}]}"
1440 ne "@{[sort %{$op->hints_hash->HASH || {}}]}") {
1441 push @text, declare_hinthash($self->{'hinthash'}, $op->hints_hash->HASH, $self->{indent_size});
1442 $self->{'hinthash'} = $op->hints_hash->HASH;
1445 # This should go after of any branches that add statements, to
1446 # increase the chances that it refers to the same line it did in
1447 # the original program.
1448 if ($self->{'linenums'}) {
1449 push @text, "\f#line " . $op->line .
1450 ' "' . $op->file, qq'"\n';
1453 push @text, $op->label . ": " if $op->label;
1455 return join("", @text);
1458 sub declare_warnings {
1459 my ($from, $to) = @_;
1460 if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
1461 return "use warnings;\n";
1463 elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
1464 return "no warnings;\n";
1466 return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
1470 my ($from, $to) = @_;
1471 my $use = $to & ~$from;
1472 my $no = $from & ~$to;
1474 for my $pragma (hint_pragmas($use)) {
1475 $decls .= "use $pragma;\n";
1477 for my $pragma (hint_pragmas($no)) {
1478 $decls .= "no $pragma;\n";
1483 # Internal implementation hints that the core sets automatically, so don't need
1484 # (or want) to be passed back to the user
1485 my %ignored_hints = (
1491 sub declare_hinthash {
1492 my ($from, $to, $indent) = @_;
1494 for my $key (keys %$to) {
1495 next if $ignored_hints{$key};
1496 if (!defined $from->{$key} or $from->{$key} ne $to->{$key}) {
1497 push @decls, qq(\$^H{'$key'} = q($to->{$key}););
1500 for my $key (keys %$from) {
1501 next if $ignored_hints{$key};
1502 if (!exists $to->{$key}) {
1503 push @decls, qq(delete \$^H{'$key'};);
1506 @decls or return '';
1507 return join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n";
1513 push @pragmas, "integer" if $bits & 0x1;
1514 push @pragmas, "strict 'refs'" if $bits & 0x2;
1515 push @pragmas, "bytes" if $bits & 0x8;
1519 sub pp_dbstate { pp_nextstate(@_) }
1520 sub pp_setstate { pp_nextstate(@_) }
1522 sub pp_unstack { return "" } # see also leaveloop
1526 my($op, $cx, $name) = @_;
1532 my($op, $cx, $name) = @_;
1540 sub pp_wantarray { baseop(@_, "wantarray") }
1541 sub pp_fork { baseop(@_, "fork") }
1542 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1543 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1544 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1545 sub pp_tms { baseop(@_, "times") }
1546 sub pp_ghostent { baseop(@_, "gethostent") }
1547 sub pp_gnetent { baseop(@_, "getnetent") }
1548 sub pp_gprotoent { baseop(@_, "getprotoent") }
1549 sub pp_gservent { baseop(@_, "getservent") }
1550 sub pp_ehostent { baseop(@_, "endhostent") }
1551 sub pp_enetent { baseop(@_, "endnetent") }
1552 sub pp_eprotoent { baseop(@_, "endprotoent") }
1553 sub pp_eservent { baseop(@_, "endservent") }
1554 sub pp_gpwent { baseop(@_, "getpwent") }
1555 sub pp_spwent { baseop(@_, "setpwent") }
1556 sub pp_epwent { baseop(@_, "endpwent") }
1557 sub pp_ggrent { baseop(@_, "getgrent") }
1558 sub pp_sgrent { baseop(@_, "setgrent") }
1559 sub pp_egrent { baseop(@_, "endgrent") }
1560 sub pp_getlogin { baseop(@_, "getlogin") }
1562 sub POSTFIX () { 1 }
1564 # I couldn't think of a good short name, but this is the category of
1565 # symbolic unary operators with interesting precedence
1569 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1570 my $kid = $op->first;
1571 $kid = $self->deparse($kid, $prec);
1572 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1576 sub pp_preinc { pfixop(@_, "++", 23) }
1577 sub pp_predec { pfixop(@_, "--", 23) }
1578 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1579 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1580 sub pp_i_preinc { pfixop(@_, "++", 23) }
1581 sub pp_i_predec { pfixop(@_, "--", 23) }
1582 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1583 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1584 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1586 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1590 if ($op->first->name =~ /^(i_)?negate$/) {
1592 $self->pfixop($op, $cx, "-", 21.5);
1594 $self->pfixop($op, $cx, "-", 21);
1597 sub pp_i_negate { pp_negate(@_) }
1603 $self->pfixop($op, $cx, "not ", 4);
1605 $self->pfixop($op, $cx, "!", 21);
1611 my($op, $cx, $name) = @_;
1613 if ($op->flags & OPf_KIDS) {
1616 # this deals with 'boolkeys' right now
1617 return $self->deparse($kid,$cx);
1619 my $builtinname = $name;
1620 $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
1621 if (defined prototype($builtinname)
1622 && prototype($builtinname) =~ /^;?\*/
1623 && $kid->name eq "rv2gv") {
1627 return $self->maybe_parens_unop($name, $kid, $cx);
1629 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1633 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1634 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1635 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1636 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1637 sub pp_defined { unop(@_, "defined") }
1638 sub pp_undef { unop(@_, "undef") }
1639 sub pp_study { unop(@_, "study") }
1640 sub pp_ref { unop(@_, "ref") }
1641 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1643 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1644 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1645 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1646 sub pp_srand { unop(@_, "srand") }
1647 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1648 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1649 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1650 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1651 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1652 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1653 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1655 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1656 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1657 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1659 sub pp_each { unop(@_, "each") }
1660 sub pp_values { unop(@_, "values") }
1661 sub pp_keys { unop(@_, "keys") }
1663 # no name because its an optimisation op that has no keyword
1666 sub pp_aeach { unop(@_, "each") }
1667 sub pp_avalues { unop(@_, "values") }
1668 sub pp_akeys { unop(@_, "keys") }
1669 sub pp_pop { unop(@_, "pop") }
1670 sub pp_shift { unop(@_, "shift") }
1672 sub pp_caller { unop(@_, "caller") }
1673 sub pp_reset { unop(@_, "reset") }
1674 sub pp_exit { unop(@_, "exit") }
1675 sub pp_prototype { unop(@_, "prototype") }
1677 sub pp_close { unop(@_, "close") }
1678 sub pp_fileno { unop(@_, "fileno") }
1679 sub pp_umask { unop(@_, "umask") }
1680 sub pp_untie { unop(@_, "untie") }
1681 sub pp_tied { unop(@_, "tied") }
1682 sub pp_dbmclose { unop(@_, "dbmclose") }
1683 sub pp_getc { unop(@_, "getc") }
1684 sub pp_eof { unop(@_, "eof") }
1685 sub pp_tell { unop(@_, "tell") }
1686 sub pp_getsockname { unop(@_, "getsockname") }
1687 sub pp_getpeername { unop(@_, "getpeername") }
1689 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1690 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1691 sub pp_readlink { unop(@_, "readlink") }
1692 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1693 sub pp_readdir { unop(@_, "readdir") }
1694 sub pp_telldir { unop(@_, "telldir") }
1695 sub pp_rewinddir { unop(@_, "rewinddir") }
1696 sub pp_closedir { unop(@_, "closedir") }
1697 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1698 sub pp_localtime { unop(@_, "localtime") }
1699 sub pp_gmtime { unop(@_, "gmtime") }
1700 sub pp_alarm { unop(@_, "alarm") }
1701 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1703 sub pp_dofile { unop(@_, "do") }
1704 sub pp_entereval { unop(@_, "eval") }
1706 sub pp_ghbyname { unop(@_, "gethostbyname") }
1707 sub pp_gnbyname { unop(@_, "getnetbyname") }
1708 sub pp_gpbyname { unop(@_, "getprotobyname") }
1709 sub pp_shostent { unop(@_, "sethostent") }
1710 sub pp_snetent { unop(@_, "setnetent") }
1711 sub pp_sprotoent { unop(@_, "setprotoent") }
1712 sub pp_sservent { unop(@_, "setservent") }
1713 sub pp_gpwnam { unop(@_, "getpwnam") }
1714 sub pp_gpwuid { unop(@_, "getpwuid") }
1715 sub pp_ggrnam { unop(@_, "getgrnam") }
1716 sub pp_ggrgid { unop(@_, "getgrgid") }
1718 sub pp_lock { unop(@_, "lock") }
1720 sub pp_continue { unop(@_, "continue"); }
1722 my ($self, $op) = @_;
1723 return "" if $op->flags & OPf_SPECIAL;
1729 my($op, $cx, $givwhen) = @_;
1731 my $enterop = $op->first;
1733 if ($enterop->flags & OPf_SPECIAL) {
1735 $block = $self->deparse($enterop->first, 0);
1738 my $cond = $enterop->first;
1739 my $cond_str = $self->deparse($cond, 1);
1740 $head = "$givwhen ($cond_str)";
1741 $block = $self->deparse($cond->sibling, 0);
1749 sub pp_leavegiven { givwhen(@_, "given"); }
1750 sub pp_leavewhen { givwhen(@_, "when"); }
1756 if ($op->private & OPpEXISTS_SUB) {
1757 # Checking for the existence of a subroutine
1758 return $self->maybe_parens_func("exists",
1759 $self->pp_rv2cv($op->first, 16), $cx, 16);
1761 if ($op->flags & OPf_SPECIAL) {
1762 # Array element, not hash element
1763 return $self->maybe_parens_func("exists",
1764 $self->pp_aelem($op->first, 16), $cx, 16);
1766 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1774 if ($op->private & OPpSLICE) {
1775 if ($op->flags & OPf_SPECIAL) {
1776 # Deleting from an array, not a hash
1777 return $self->maybe_parens_func("delete",
1778 $self->pp_aslice($op->first, 16),
1781 return $self->maybe_parens_func("delete",
1782 $self->pp_hslice($op->first, 16),
1785 if ($op->flags & OPf_SPECIAL) {
1786 # Deleting from an array, not a hash
1787 return $self->maybe_parens_func("delete",
1788 $self->pp_aelem($op->first, 16),
1791 return $self->maybe_parens_func("delete",
1792 $self->pp_helem($op->first, 16),
1800 my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
1801 if (class($op) eq "UNOP" and $op->first->name eq "const"
1802 and $op->first->private & OPpCONST_BARE)
1804 my $name = $self->const_sv($op->first)->PV;
1807 return "$opname $name";
1809 $self->unop($op, $cx, $op->first->private & OPpCONST_NOVER ? "no" : $opname);
1816 my $kid = $op->first;
1817 if (not null $kid->sibling) {
1818 # XXX Was a here-doc
1819 return $self->dquote($op);
1821 $self->unop(@_, "scalar");
1828 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
1831 sub anon_hash_or_list {
1835 my($pre, $post) = @{{"anonlist" => ["[","]"],
1836 "anonhash" => ["{","}"]}->{$op->name}};
1838 $op = $op->first->sibling; # skip pushmark
1839 for (; !null($op); $op = $op->sibling) {
1840 $expr = $self->deparse($op, 6);
1843 if ($pre eq "{" and $cx < 1) {
1844 # Disambiguate that it's not a block
1847 return $pre . join(", ", @exprs) . $post;
1853 if ($op->flags & OPf_SPECIAL) {
1854 return $self->anon_hash_or_list($op, $cx);
1856 warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
1860 *pp_anonhash = \&pp_anonlist;
1865 my $kid = $op->first;
1866 if ($kid->name eq "null") {
1868 if (!null($kid->sibling) and
1869 $kid->sibling->name eq "anoncode") {
1870 return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) });
1871 } elsif ($kid->name eq "pushmark") {
1872 my $sib_name = $kid->sibling->name;
1873 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1874 and not $kid->sibling->flags & OPf_REF)
1876 # The @a in \(@a) isn't in ref context, but only when the
1878 return "\\(" . $self->pp_list($op->first) . ")";
1879 } elsif ($sib_name eq 'entersub') {
1880 my $text = $self->deparse($kid->sibling, 1);
1881 # Always show parens for \(&func()), but only with -p otherwise
1882 $text = "($text)" if $self->{'parens'}
1883 or $kid->sibling->private & OPpENTERSUB_AMPER;
1888 $self->pfixop($op, $cx, "\\", 20);
1892 my ($self, $info) = @_;
1893 my $text = $self->deparse_sub($info->{code});
1894 return "sub " . $text;
1897 sub pp_srefgen { pp_refgen(@_) }
1902 my $kid = $op->first;
1903 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1904 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1905 return $self->unop($op, $cx, "readline");
1911 return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
1914 # Unary operators that can occur as pseudo-listops inside double quotes
1917 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1919 if ($op->flags & OPf_KIDS) {
1921 # If there's more than one kid, the first is an ex-pushmark.
1922 $kid = $kid->sibling if not null $kid->sibling;
1923 return $self->maybe_parens_unop($name, $kid, $cx);
1925 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1929 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1930 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1931 sub pp_uc { dq_unop(@_, "uc") }
1932 sub pp_lc { dq_unop(@_, "lc") }
1933 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1937 my ($op, $cx, $name) = @_;
1938 if (class($op) eq "PVOP") {
1939 return "$name " . $op->pv;
1940 } elsif (class($op) eq "OP") {
1942 } elsif (class($op) eq "UNOP") {
1943 # Note -- loop exits are actually exempt from the
1944 # looks-like-a-func rule, but a few extra parens won't hurt
1945 return $self->maybe_parens_unop($name, $op->first, $cx);
1949 sub pp_last { loopex(@_, "last") }
1950 sub pp_next { loopex(@_, "next") }
1951 sub pp_redo { loopex(@_, "redo") }
1952 sub pp_goto { loopex(@_, "goto") }
1953 sub pp_dump { loopex(@_, "dump") }
1957 my($op, $cx, $name) = @_;
1958 if (class($op) eq "UNOP") {
1959 # Genuine `-X' filetests are exempt from the LLAFR, but not
1960 # l?stat(); for the sake of clarity, give'em all parens
1961 return $self->maybe_parens_unop($name, $op->first, $cx);
1962 } elsif (class($op) =~ /^(SV|PAD)OP$/) {
1963 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1964 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1969 sub pp_lstat { ftst(@_, "lstat") }
1970 sub pp_stat { ftst(@_, "stat") }
1971 sub pp_ftrread { ftst(@_, "-R") }
1972 sub pp_ftrwrite { ftst(@_, "-W") }
1973 sub pp_ftrexec { ftst(@_, "-X") }
1974 sub pp_fteread { ftst(@_, "-r") }
1975 sub pp_ftewrite { ftst(@_, "-w") }
1976 sub pp_fteexec { ftst(@_, "-x") }
1977 sub pp_ftis { ftst(@_, "-e") }
1978 sub pp_fteowned { ftst(@_, "-O") }
1979 sub pp_ftrowned { ftst(@_, "-o") }
1980 sub pp_ftzero { ftst(@_, "-z") }
1981 sub pp_ftsize { ftst(@_, "-s") }
1982 sub pp_ftmtime { ftst(@_, "-M") }
1983 sub pp_ftatime { ftst(@_, "-A") }
1984 sub pp_ftctime { ftst(@_, "-C") }
1985 sub pp_ftsock { ftst(@_, "-S") }
1986 sub pp_ftchr { ftst(@_, "-c") }
1987 sub pp_ftblk { ftst(@_, "-b") }
1988 sub pp_ftfile { ftst(@_, "-f") }
1989 sub pp_ftdir { ftst(@_, "-d") }
1990 sub pp_ftpipe { ftst(@_, "-p") }
1991 sub pp_ftlink { ftst(@_, "-l") }
1992 sub pp_ftsuid { ftst(@_, "-u") }
1993 sub pp_ftsgid { ftst(@_, "-g") }
1994 sub pp_ftsvtx { ftst(@_, "-k") }
1995 sub pp_fttty { ftst(@_, "-t") }
1996 sub pp_fttext { ftst(@_, "-T") }
1997 sub pp_ftbinary { ftst(@_, "-B") }
1999 sub SWAP_CHILDREN () { 1 }
2000 sub ASSIGN () { 2 } # has OP= variant
2001 sub LIST_CONTEXT () { 4 } # Assignment is in list context
2007 my $name = $op->name;
2008 if ($name eq "concat" and $op->first->name eq "concat") {
2009 # avoid spurious `=' -- see comment in pp_concat
2012 if ($name eq "null" and class($op) eq "UNOP"
2013 and $op->first->name =~ /^(and|x?or)$/
2014 and null $op->first->sibling)
2016 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
2017 # with a null that's used as the common end point of the two
2018 # flows of control. For precedence purposes, ignore it.
2019 # (COND_EXPRs have these too, but we don't bother with
2020 # their associativity).
2021 return assoc_class($op->first);
2023 return $name . ($op->flags & OPf_STACKED ? "=" : "");
2026 # Left associative operators, like `+', for which
2027 # $a + $b + $c is equivalent to ($a + $b) + $c
2030 %left = ('multiply' => 19, 'i_multiply' => 19,
2031 'divide' => 19, 'i_divide' => 19,
2032 'modulo' => 19, 'i_modulo' => 19,
2034 'add' => 18, 'i_add' => 18,
2035 'subtract' => 18, 'i_subtract' => 18,
2037 'left_shift' => 17, 'right_shift' => 17,
2039 'bit_or' => 12, 'bit_xor' => 12,
2041 'or' => 2, 'xor' => 2,
2045 sub deparse_binop_left {
2047 my($op, $left, $prec) = @_;
2048 if ($left{assoc_class($op)} && $left{assoc_class($left)}
2049 and $left{assoc_class($op)} == $left{assoc_class($left)})
2051 return $self->deparse($left, $prec - .00001);
2053 return $self->deparse($left, $prec);
2057 # Right associative operators, like `=', for which
2058 # $a = $b = $c is equivalent to $a = ($b = $c)
2061 %right = ('pow' => 22,
2062 'sassign=' => 7, 'aassign=' => 7,
2063 'multiply=' => 7, 'i_multiply=' => 7,
2064 'divide=' => 7, 'i_divide=' => 7,
2065 'modulo=' => 7, 'i_modulo=' => 7,
2067 'add=' => 7, 'i_add=' => 7,
2068 'subtract=' => 7, 'i_subtract=' => 7,
2070 'left_shift=' => 7, 'right_shift=' => 7,
2072 'bit_or=' => 7, 'bit_xor=' => 7,
2078 sub deparse_binop_right {
2080 my($op, $right, $prec) = @_;
2081 if ($right{assoc_class($op)} && $right{assoc_class($right)}
2082 and $right{assoc_class($op)} == $right{assoc_class($right)})
2084 return $self->deparse($right, $prec - .00001);
2086 return $self->deparse($right, $prec);
2092 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
2093 my $left = $op->first;
2094 my $right = $op->last;
2096 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
2100 if ($flags & SWAP_CHILDREN) {
2101 ($left, $right) = ($right, $left);
2103 $left = $self->deparse_binop_left($op, $left, $prec);
2104 $left = "($left)" if $flags & LIST_CONTEXT
2105 && $left !~ /^(my|our|local|)[\@\(]/;
2106 $right = $self->deparse_binop_right($op, $right, $prec);
2107 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
2110 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2111 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2112 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
2113 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2114 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2115 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2116 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2117 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
2118 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2119 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2120 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
2122 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
2123 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
2124 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
2125 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
2126 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
2128 sub pp_eq { binop(@_, "==", 14) }
2129 sub pp_ne { binop(@_, "!=", 14) }
2130 sub pp_lt { binop(@_, "<", 15) }
2131 sub pp_gt { binop(@_, ">", 15) }
2132 sub pp_ge { binop(@_, ">=", 15) }
2133 sub pp_le { binop(@_, "<=", 15) }
2134 sub pp_ncmp { binop(@_, "<=>", 14) }
2135 sub pp_i_eq { binop(@_, "==", 14) }
2136 sub pp_i_ne { binop(@_, "!=", 14) }
2137 sub pp_i_lt { binop(@_, "<", 15) }
2138 sub pp_i_gt { binop(@_, ">", 15) }
2139 sub pp_i_ge { binop(@_, ">=", 15) }
2140 sub pp_i_le { binop(@_, "<=", 15) }
2141 sub pp_i_ncmp { binop(@_, "<=>", 14) }
2143 sub pp_seq { binop(@_, "eq", 14) }
2144 sub pp_sne { binop(@_, "ne", 14) }
2145 sub pp_slt { binop(@_, "lt", 15) }
2146 sub pp_sgt { binop(@_, "gt", 15) }
2147 sub pp_sge { binop(@_, "ge", 15) }
2148 sub pp_sle { binop(@_, "le", 15) }
2149 sub pp_scmp { binop(@_, "cmp", 14) }
2151 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
2152 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
2155 my ($self, $op, $cx) = @_;
2156 if ($op->flags & OPf_SPECIAL) {
2157 return $self->deparse($op->last, $cx);
2160 binop(@_, "~~", 14);
2164 # `.' is special because concats-of-concats are optimized to save copying
2165 # by making all but the first concat stacked. The effect is as if the
2166 # programmer had written `($a . $b) .= $c', except legal.
2167 sub pp_concat { maybe_targmy(@_, \&real_concat) }
2171 my $left = $op->first;
2172 my $right = $op->last;
2175 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
2179 $left = $self->deparse_binop_left($op, $left, $prec);
2180 $right = $self->deparse_binop_right($op, $right, $prec);
2181 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
2184 # `x' is weird when the left arg is a list
2188 my $left = $op->first;
2189 my $right = $op->last;
2192 if ($op->flags & OPf_STACKED) {
2196 if (null($right)) { # list repeat; count is inside left-side ex-list
2197 my $kid = $left->first->sibling; # skip pushmark
2199 for (; !null($kid->sibling); $kid = $kid->sibling) {
2200 push @exprs, $self->deparse($kid, 6);
2203 $left = "(" . join(", ", @exprs). ")";
2205 $left = $self->deparse_binop_left($op, $left, $prec);
2207 $right = $self->deparse_binop_right($op, $right, $prec);
2208 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
2213 my ($op, $cx, $type) = @_;
2214 my $left = $op->first;
2215 my $right = $left->sibling;
2216 $left = $self->deparse($left, 9);
2217 $right = $self->deparse($right, 9);
2218 return $self->maybe_parens("$left $type $right", $cx, 9);
2224 my $flip = $op->first;
2225 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
2226 return $self->range($flip->first, $cx, $type);
2229 # one-line while/until is handled in pp_leave
2233 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
2234 my $left = $op->first;
2235 my $right = $op->first->sibling;
2236 if ($cx < 1 and is_scope($right) and $blockname
2237 and $self->{'expand'} < 7)
2239 $left = $self->deparse($left, 1);
2240 $right = $self->deparse($right, 0);
2241 return "$blockname ($left) {\n\t$right\n\b}\cK";
2242 } elsif ($cx < 1 and $blockname and not $self->{'parens'}
2243 and $self->{'expand'} < 7) { # $b if $a
2244 $right = $self->deparse($right, 1);
2245 $left = $self->deparse($left, 1);
2246 return "$right $blockname $left";
2247 } elsif ($cx > $lowprec and $highop) { # $a && $b
2248 $left = $self->deparse_binop_left($op, $left, $highprec);
2249 $right = $self->deparse_binop_right($op, $right, $highprec);
2250 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
2251 } else { # $a and $b
2252 $left = $self->deparse_binop_left($op, $left, $lowprec);
2253 $right = $self->deparse_binop_right($op, $right, $lowprec);
2254 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
2258 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
2259 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
2260 sub pp_dor { logop(@_, "//", 10) }
2262 # xor is syntactically a logop, but it's really a binop (contrary to
2263 # old versions of opcode.pl). Syntax is what matters here.
2264 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
2268 my ($op, $cx, $opname) = @_;
2269 my $left = $op->first;
2270 my $right = $op->first->sibling->first; # skip sassign
2271 $left = $self->deparse($left, 7);
2272 $right = $self->deparse($right, 7);
2273 return $self->maybe_parens("$left $opname $right", $cx, 7);
2276 sub pp_andassign { logassignop(@_, "&&=") }
2277 sub pp_orassign { logassignop(@_, "||=") }
2278 sub pp_dorassign { logassignop(@_, "//=") }
2282 my($op, $cx, $name) = @_;
2284 my $parens = ($cx >= 5) || $self->{'parens'};
2285 my $kid = $op->first->sibling;
2286 return $name if null $kid;
2288 $name = "socketpair" if $name eq "sockpair";
2289 my $proto = prototype("CORE::$name");
2291 && $proto =~ /^;?\*/
2292 && $kid->name eq "rv2gv") {
2293 $first = $self->deparse($kid->first, 6);
2296 $first = $self->deparse($kid, 6);
2298 if ($name eq "chmod" && $first =~ /^\d+$/) {
2299 $first = sprintf("%#o", $first);
2301 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
2302 push @exprs, $first;
2303 $kid = $kid->sibling;
2304 if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
2305 push @exprs, $self->deparse($kid->first, 6);
2306 $kid = $kid->sibling;
2308 for (; !null($kid); $kid = $kid->sibling) {
2309 push @exprs, $self->deparse($kid, 6);
2311 if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
2312 return "$exprs[0] = $name" . ($parens ? "($exprs[0])" : " $exprs[0]");
2315 return "$name(" . join(", ", @exprs) . ")";
2317 return "$name " . join(", ", @exprs);
2321 sub pp_bless { listop(@_, "bless") }
2322 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2323 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
2324 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2325 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2326 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2327 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2328 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2329 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2330 sub pp_unpack { listop(@_, "unpack") }
2331 sub pp_pack { listop(@_, "pack") }
2332 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2333 sub pp_splice { listop(@_, "splice") }
2334 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2335 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2336 sub pp_reverse { listop(@_, "reverse") }
2337 sub pp_warn { listop(@_, "warn") }
2338 sub pp_die { listop(@_, "die") }
2339 # Actually, return is exempt from the LLAFR (see examples in this very
2340 # module!), but for consistency's sake, ignore that fact
2341 sub pp_return { listop(@_, "return") }
2342 sub pp_open { listop(@_, "open") }
2343 sub pp_pipe_op { listop(@_, "pipe") }
2344 sub pp_tie { listop(@_, "tie") }
2345 sub pp_binmode { listop(@_, "binmode") }
2346 sub pp_dbmopen { listop(@_, "dbmopen") }
2347 sub pp_sselect { listop(@_, "select") }
2348 sub pp_select { listop(@_, "select") }
2349 sub pp_read { listop(@_, "read") }
2350 sub pp_sysopen { listop(@_, "sysopen") }
2351 sub pp_sysseek { listop(@_, "sysseek") }
2352 sub pp_sysread { listop(@_, "sysread") }
2353 sub pp_syswrite { listop(@_, "syswrite") }
2354 sub pp_send { listop(@_, "send") }
2355 sub pp_recv { listop(@_, "recv") }
2356 sub pp_seek { listop(@_, "seek") }
2357 sub pp_fcntl { listop(@_, "fcntl") }
2358 sub pp_ioctl { listop(@_, "ioctl") }
2359 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2360 sub pp_socket { listop(@_, "socket") }
2361 sub pp_sockpair { listop(@_, "sockpair") }
2362 sub pp_bind { listop(@_, "bind") }
2363 sub pp_connect { listop(@_, "connect") }
2364 sub pp_listen { listop(@_, "listen") }
2365 sub pp_accept { listop(@_, "accept") }
2366 sub pp_shutdown { listop(@_, "shutdown") }
2367 sub pp_gsockopt { listop(@_, "getsockopt") }
2368 sub pp_ssockopt { listop(@_, "setsockopt") }
2369 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2370 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2371 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2372 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2373 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2374 sub pp_link { maybe_targmy(@_, \&listop, "link") }
2375 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2376 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2377 sub pp_open_dir { listop(@_, "opendir") }
2378 sub pp_seekdir { listop(@_, "seekdir") }
2379 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2380 sub pp_system { maybe_targmy(@_, \&listop, "system") }
2381 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2382 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2383 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2384 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2385 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2386 sub pp_shmget { listop(@_, "shmget") }
2387 sub pp_shmctl { listop(@_, "shmctl") }
2388 sub pp_shmread { listop(@_, "shmread") }
2389 sub pp_shmwrite { listop(@_, "shmwrite") }
2390 sub pp_msgget { listop(@_, "msgget") }
2391 sub pp_msgctl { listop(@_, "msgctl") }
2392 sub pp_msgsnd { listop(@_, "msgsnd") }
2393 sub pp_msgrcv { listop(@_, "msgrcv") }
2394 sub pp_semget { listop(@_, "semget") }
2395 sub pp_semctl { listop(@_, "semctl") }
2396 sub pp_semop { listop(@_, "semop") }
2397 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2398 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2399 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2400 sub pp_gsbyname { listop(@_, "getservbyname") }
2401 sub pp_gsbyport { listop(@_, "getservbyport") }
2402 sub pp_syscall { listop(@_, "syscall") }
2407 my $text = $self->dq($op->first->sibling); # skip pushmark
2408 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
2409 or $text =~ /[<>]/) {
2410 return 'glob(' . single_delim('qq', '"', $text) . ')';
2412 return '<' . $text . '>';
2416 # Truncate is special because OPf_SPECIAL makes a bareword first arg
2417 # be a filehandle. This could probably be better fixed in the core
2418 # by moving the GV lookup into ck_truc.
2424 my $parens = ($cx >= 5) || $self->{'parens'};
2425 my $kid = $op->first->sibling;
2427 if ($op->flags & OPf_SPECIAL) {
2428 # $kid is an OP_CONST
2429 $fh = $self->const_sv($kid)->PV;
2431 $fh = $self->deparse($kid, 6);
2432 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2434 my $len = $self->deparse($kid->sibling, 6);
2436 return "truncate($fh, $len)";
2438 return "truncate $fh, $len";
2444 my($op, $cx, $name) = @_;
2446 my $kid = $op->first->sibling;
2448 if ($op->flags & OPf_STACKED) {
2450 $indir = $indir->first; # skip rv2gv
2451 if (is_scope($indir)) {
2452 $indir = "{" . $self->deparse($indir, 0) . "}";
2453 $indir = "{;}" if $indir eq "{}";
2454 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
2455 $indir = $self->const_sv($indir)->PV;
2457 $indir = $self->deparse($indir, 24);
2459 $indir = $indir . " ";
2460 $kid = $kid->sibling;
2462 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
2463 $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
2466 elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
2467 $indir = '{$b cmp $a} ';
2469 for (; !null($kid); $kid = $kid->sibling) {
2470 $expr = $self->deparse($kid, 6);
2474 if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
2475 $name2 = 'reverse sort';
2477 if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
2478 return "$exprs[0] = $name2 $indir $exprs[0]";
2481 my $args = $indir . join(", ", @exprs);
2482 if ($indir ne "" and $name eq "sort") {
2483 # We don't want to say "sort(f 1, 2, 3)", since perl -w will
2484 # give bareword warnings in that case. Therefore if context
2485 # requires, we'll put parens around the outside "(sort f 1, 2,
2486 # 3)". Unfortunately, we'll currently think the parens are
2487 # necessary more often that they really are, because we don't
2488 # distinguish which side of an assignment we're on.
2490 return "($name2 $args)";
2492 return "$name2 $args";
2495 return $self->maybe_parens_func($name2, $args, $cx, 5);
2500 sub pp_prtf { indirop(@_, "printf") }
2501 sub pp_print { indirop(@_, "print") }
2502 sub pp_say { indirop(@_, "say") }
2503 sub pp_sort { indirop(@_, "sort") }
2507 my($op, $cx, $name) = @_;
2509 my $kid = $op->first; # this is the (map|grep)start
2510 $kid = $kid->first->sibling; # skip a pushmark
2511 my $code = $kid->first; # skip a null
2512 if (is_scope $code) {
2513 $code = "{" . $self->deparse($code, 0) . "} ";
2515 $code = $self->deparse($code, 24) . ", ";
2517 $kid = $kid->sibling;
2518 for (; !null($kid); $kid = $kid->sibling) {
2519 $expr = $self->deparse($kid, 6);
2520 push @exprs, $expr if defined $expr;
2522 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2525 sub pp_mapwhile { mapop(@_, "map") }
2526 sub pp_grepwhile { mapop(@_, "grep") }
2527 sub pp_mapstart { baseop(@_, "map") }
2528 sub pp_grepstart { baseop(@_, "grep") }
2534 my $kid = $op->first->sibling; # skip pushmark
2536 my $local = "either"; # could be local(...), my(...), state(...) or our(...)
2537 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2538 # This assumes that no other private flags equal 128, and that
2539 # OPs that store things other than flags in their op_private,
2540 # like OP_AELEMFAST, won't be immediate children of a list.
2542 # OP_ENTERSUB can break this logic, so check for it.
2543 # I suspect that open and exit can too.
2545 if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
2546 or $lop->name eq "undef")
2547 or $lop->name eq "entersub"
2548 or $lop->name eq "exit"
2549 or $lop->name eq "open")
2551 $local = ""; # or not
2554 if ($lop->name =~ /^pad[ash]v$/) {
2555 if ($lop->private & OPpPAD_STATE) { # state()
2556 ($local = "", last) if $local =~ /^(?:local|our|my)$/;
2559 ($local = "", last) if $local =~ /^(?:local|our|state)$/;
2562 } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
2563 && $lop->private & OPpOUR_INTRO
2564 or $lop->name eq "null" && $lop->first->name eq "gvsv"
2565 && $lop->first->private & OPpOUR_INTRO) { # our()
2566 ($local = "", last) if $local =~ /^(?:my|local|state)$/;
2568 } elsif ($lop->name ne "undef"
2569 # specifically avoid the "reverse sort" optimisation,
2570 # where "reverse" is nullified
2571 && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
2574 ($local = "", last) if $local =~ /^(?:my|our|state)$/;
2578 $local = "" if $local eq "either"; # no point if it's all undefs
2579 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2580 for (; !null($kid); $kid = $kid->sibling) {
2582 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2587 $self->{'avoid_local'}{$$lop}++;
2588 $expr = $self->deparse($kid, 6);
2589 delete $self->{'avoid_local'}{$$lop};
2591 $expr = $self->deparse($kid, 6);
2596 return "$local(" . join(", ", @exprs) . ")";
2598 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2602 sub is_ifelse_cont {
2604 return ($op->name eq "null" and class($op) eq "UNOP"
2605 and $op->first->name =~ /^(and|cond_expr)$/
2606 and is_scope($op->first->first->sibling));
2612 my $cond = $op->first;
2613 my $true = $cond->sibling;
2614 my $false = $true->sibling;
2615 my $cuddle = $self->{'cuddle'};
2616 unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
2617 (is_scope($false) || is_ifelse_cont($false))
2618 and $self->{'expand'} < 7) {
2619 $cond = $self->deparse($cond, 8);
2620 $true = $self->deparse($true, 6);
2621 $false = $self->deparse($false, 8);
2622 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2625 $cond = $self->deparse($cond, 1);
2626 $true = $self->deparse($true, 0);
2627 my $head = "if ($cond) {\n\t$true\n\b}";
2629 while (!null($false) and is_ifelse_cont($false)) {
2630 my $newop = $false->first;
2631 my $newcond = $newop->first;
2632 my $newtrue = $newcond->sibling;
2633 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2634 if ($newcond->name eq "lineseq")
2636 # lineseq to ensure correct line numbers in elsif()
2637 # Bug #37302 fixed by change #33710.
2638 $newcond = $newcond->first->sibling;
2640 $newcond = $self->deparse($newcond, 1);
2641 $newtrue = $self->deparse($newtrue, 0);
2642 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2644 if (!null($false)) {
2645 $false = $cuddle . "else {\n\t" .
2646 $self->deparse($false, 0) . "\n\b}\cK";
2650 return $head . join($cuddle, "", @elsifs) . $false;
2654 my ($self, $op, $cx) = @_;
2655 my $cond = $op->first;
2656 my $true = $cond->sibling;
2658 return $self->deparse($true, $cx);
2663 my($op, $cx, $init) = @_;
2664 my $enter = $op->first;
2665 my $kid = $enter->sibling;
2666 local(@$self{qw'curstash warnings hints hinthash'})
2667 = @$self{qw'curstash warnings hints hinthash'};
2672 if ($kid->name eq "lineseq") { # bare or infinite loop
2673 if ($kid->last->name eq "unstack") { # infinite
2674 $head = "while (1) "; # Can't use for(;;) if there's a continue
2680 } elsif ($enter->name eq "enteriter") { # foreach
2681 my $ary = $enter->first->sibling; # first was pushmark
2682 my $var = $ary->sibling;
2683 if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
2684 # "reverse" was optimised away
2685 $ary = listop($self, $ary->first->sibling, 1, 'reverse');
2686 } elsif ($enter->flags & OPf_STACKED
2687 and not null $ary->first->sibling->sibling)
2689 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2690 $self->deparse($ary->first->sibling->sibling, 9);
2692 $ary = $self->deparse($ary, 1);
2695 if (($enter->flags & OPf_SPECIAL) && ($] < 5.009)) {
2696 # thread special var, under 5005threads
2697 $var = $self->pp_threadsv($enter, 1);
2698 } else { # regular my() variable
2699 $var = $self->pp_padsv($enter, 1);
2701 } elsif ($var->name eq "rv2gv") {
2702 $var = $self->pp_rv2sv($var, 1);
2703 if ($enter->private & OPpOUR_INTRO) {
2704 # our declarations don't have package names
2705 $var =~ s/^(.).*::/$1/;
2708 } elsif ($var->name eq "gv") {
2709 $var = "\$" . $self->deparse($var, 1);
2711 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2712 if (!is_state $body->first and $body->first->name ne "stub") {
2713 confess unless $var eq '$_';
2714 $body = $body->first;
2715 return $self->deparse($body, 2) . " foreach ($ary)";
2717 $head = "foreach $var ($ary) ";
2718 } elsif ($kid->name eq "null") { # while/until
2720 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2721 $cond = $self->deparse($kid->first, 1);
2722 $head = "$name ($cond) ";
2723 $body = $kid->first->sibling;
2724 } elsif ($kid->name eq "stub") { # bare and empty
2725 return "{;}"; # {} could be a hashref
2727 # If there isn't a continue block, then the next pointer for the loop
2728 # will point to the unstack, which is kid's last child, except
2729 # in a bare loop, when it will point to the leaveloop. When neither of
2730 # these conditions hold, then the second-to-last child is the continue
2731 # block (or the last in a bare loop).
2732 my $cont_start = $enter->nextop;
2734 if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
2736 $cont = $body->last;
2738 $cont = $body->first;
2739 while (!null($cont->sibling->sibling)) {
2740 $cont = $cont->sibling;
2743 my $state = $body->first;
2744 my $cuddle = $self->{'cuddle'};
2746 for (; $$state != $$cont; $state = $state->sibling) {
2747 push @states, $state;
2749 $body = $self->lineseq(undef, @states);
2750 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2751 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2754 $cont = $cuddle . "continue {\n\t" .
2755 $self->deparse($cont, 0) . "\n\b}\cK";
2758 return "" if !defined $body;
2760 $head = "for ($init; $cond;) ";
2763 $body = $self->deparse($body, 0);
2765 $body =~ s/;?$/;\n/;
2767 return $head . "{\n\t" . $body . "\b}" . $cont;
2770 sub pp_leaveloop { shift->loop_common(@_, "") }
2775 my $init = $self->deparse($op, 1);
2776 my $s = $op->sibling;
2777 my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
2778 return $self->loop_common($ll, $cx, $init);
2783 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2786 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2787 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2788 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
2789 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
2794 if (class($op) eq "OP") {
2796 return $self->{'ex_const'} if $op->targ == OP_CONST;
2797 } elsif ($op->first->name eq "pushmark") {
2798 return $self->pp_list($op, $cx);
2799 } elsif ($op->first->name eq "enter") {
2800 return $self->pp_leave($op, $cx);
2801 } elsif ($op->first->name eq "leave") {
2802 return $self->pp_leave($op->first, $cx);
2803 } elsif ($op->first->name eq "scope") {
2804 return $self->pp_scope($op->first, $cx);
2805 } elsif ($op->targ == OP_STRINGIFY) {
2806 return $self->dquote($op, $cx);
2807 } elsif (!null($op->first->sibling) and
2808 $op->first->sibling->name eq "readline" and
2809 $op->first->sibling->flags & OPf_STACKED) {
2810 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2811 . $self->deparse($op->first->sibling, 7),
2813 } elsif (!null($op->first->sibling) and
2814 $op->first->sibling->name eq "trans" and
2815 $op->first->sibling->flags & OPf_STACKED) {
2816 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2817 . $self->deparse($op->first->sibling, 20),
2819 } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
2820 return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2821 } elsif (!null($op->first->sibling) and
2822 $op->first->sibling->name eq "null" and
2823 class($op->first->sibling) eq "UNOP" and
2824 $op->first->sibling->first->flags & OPf_STACKED and
2825 $op->first->sibling->first->name eq "rcatline") {
2826 return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
2827 . $self->deparse($op->first->sibling, 18),
2830 return $self->deparse($op->first, $cx);
2837 return $self->padname_sv($targ)->PVX;
2843 return substr($self->padname($op->targ), 1); # skip $/@/%
2849 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2852 sub pp_padav { pp_padsv(@_) }
2853 sub pp_padhv { pp_padsv(@_) }
2855 my @threadsv_names = B::threadsv_names;
2859 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2865 if (class($op) eq "PADOP") {
2866 return $self->padval($op->padix);
2867 } else { # class($op) eq "SVOP"
2875 my $gv = $self->gv_or_padgv($op);
2876 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2877 $self->gv_name($gv)));
2883 my $gv = $self->gv_or_padgv($op);
2884 return $self->gv_name($gv);
2891 if ($op->flags & OPf_SPECIAL) { # optimised PADAV
2892 $name = $self->padname($op->targ);
2896 my $gv = $self->gv_or_padgv($op);
2897 $name = $self->gv_name($gv);
2898 $name = $self->{'curstash'}."::$name"
2899 if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2900 $name = '$' . $name;
2903 return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
2908 my($op, $cx, $type) = @_;
2910 if (class($op) eq 'NULL' || !$op->can("first")) {
2911 carp("Unexpected op in pp_rv2x");
2914 my $kid = $op->first;
2915 if ($kid->name eq "gv") {
2916 return $self->stash_variable($type, $self->deparse($kid, 0));
2917 } elsif (is_scalar $kid) {
2918 my $str = $self->deparse($kid, 0);
2919 if ($str =~ /^\$([^\w\d])\z/) {
2920 # "$$+" isn't a legal way to write the scalar dereference
2921 # of $+, since the lexer can't tell you aren't trying to
2922 # do something like "$$ + 1" to get one more than your
2923 # PID. Either "${$+}" or "$${+}" are workable
2924 # disambiguations, but if the programmer did the former,
2925 # they'd be in the "else" clause below rather than here.
2926 # It's not clear if this should somehow be unified with
2927 # the code in dq and re_dq that also adds lexer
2928 # disambiguation braces.
2929 $str = '$' . "{$1}"; #'
2931 return $type . $str;
2933 return $type . "{" . $self->deparse($kid, 0) . "}";
2937 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2938 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2939 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2945 if ($op->first->name eq "padav") {
2946 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2948 return $self->maybe_local($op, $cx,
2949 $self->rv2x($op->first, $cx, '$#'));
2953 # skip down to the old, ex-rv2cv
2955 my ($self, $op, $cx) = @_;
2956 if (!null($op->first) && $op->first->name eq 'null' &&
2957 $op->first->targ eq OP_LIST)
2959 return $self->rv2x($op->first->first->sibling, $cx, "&")
2962 return $self->rv2x($op, $cx, "")
2968 my($cx, @list) = @_;
2969 my @a = map $self->const($_, 6), @list;
2974 } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
2975 # collapse (-1,0,1,2) into (-1..2)
2976 my ($s, $e) = @a[0,-1];
2978 return $self->maybe_parens("$s..$e", $cx, 9)
2979 unless grep $i++ != $_, @a;
2981 return $self->maybe_parens(join(", ", @a), $cx, 6);
2987 my $kid = $op->first;
2988 if ($kid->name eq "const") { # constant list
2989 my $av = $self->const_sv($kid);
2990 return $self->list_const($cx, $av->ARRAY);
2992 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2996 sub is_subscriptable {
2998 if ($op->name =~ /^[ahg]elem/) {
3000 } elsif ($op->name eq "entersub") {
3001 my $kid = $op->first;
3002 return 0 unless null $kid->sibling;
3004 $kid = $kid->sibling until null $kid->sibling;
3005 return 0 if is_scope($kid);
3007 return 0 if $kid->name eq "gv";
3008 return 0 if is_scalar($kid);
3009 return is_subscriptable($kid);
3015 sub elem_or_slice_array_name
3018 my ($array, $left, $padname, $allow_arrow) = @_;
3020 if ($array->name eq $padname) {
3021 return $self->padany($array);
3022 } elsif (is_scope($array)) { # ${expr}[0]
3023 return "{" . $self->deparse($array, 0) . "}";
3024 } elsif ($array->name eq "gv") {
3025 $array = $self->gv_name($self->gv_or_padgv($array));
3026 if ($array !~ /::/) {
3027 my $prefix = ($left eq '[' ? '@' : '%');
3028 $array = $self->{curstash}.'::'.$array
3029 if $self->lex_in_scope($prefix . $array);
3032 } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
3033 return $self->deparse($array, 24);
3039 sub elem_or_slice_single_index
3044 $idx = $self->deparse($idx, 1);
3046 # Outer parens in an array index will confuse perl
3047 # if we're interpolating in a regular expression, i.e.
3048 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
3050 # If $self->{parens}, then an initial '(' will
3051 # definitely be paired with a final ')'. If
3052 # !$self->{parens}, the misleading parens won't
3053 # have been added in the first place.
3055 # [You might think that we could get "(...)...(...)"
3056 # where the initial and final parens do not match
3057 # each other. But we can't, because the above would
3058 # only happen if there's an infix binop between the
3059 # two pairs of parens, and *that* means that the whole
3060 # expression would be parenthesized as well.]
3062 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
3064 # Hash-element braces will autoquote a bareword inside themselves.
3065 # We need to make sure that C<$hash{warn()}> doesn't come out as
3066 # C<$hash{warn}>, which has a quite different meaning. Currently
3067 # B::Deparse will always quote strings, even if the string was a
3068 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
3069 # for constant strings.) So we can cheat slightly here - if we see
3070 # a bareword, we know that it is supposed to be a function call.
3072 $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
3079 my ($op, $cx, $left, $right, $padname) = @_;
3080 my($array, $idx) = ($op->first, $op->first->sibling);
3082 $idx = $self->elem_or_slice_single_index($idx);
3084 unless ($array->name eq $padname) { # Maybe this has been fixed
3085 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
3087 if (my $array_name=$self->elem_or_slice_array_name
3088 ($array, $left, $padname, 1)) {
3089 return "\$" . $array_name . $left . $idx . $right;
3091 # $x[20][3]{hi} or expr->[20]
3092 my $arrow = is_subscriptable($array) ? "" : "->";
3093 return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
3098 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
3099 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
3104 my($glob, $part) = ($op->first, $op->last);
3105 $glob = $glob->first; # skip rv2gv
3106 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
3107 my $scope = is_scope($glob);
3108 $glob = $self->deparse($glob, 0);
3109 $part = $self->deparse($part, 1);
3110 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
3115 my ($op, $cx, $left, $right, $regname, $padname) = @_;
3117 my(@elems, $kid, $array, $list);
3118 if (class($op) eq "LISTOP") {
3120 } else { # ex-hslice inside delete()
3121 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
3125 $array = $array->first
3126 if $array->name eq $regname or $array->name eq "null";
3127 $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
3128 $kid = $op->first->sibling; # skip pushmark
3129 if ($kid->name eq "list") {
3130 $kid = $kid->first->sibling; # skip list, pushmark
3131 for (; !null $kid; $kid = $kid->sibling) {
3132 push @elems, $self->deparse($kid, 6);
3134 $list = join(", ", @elems);
3136 $list = $self->elem_or_slice_single_index($kid);
3138 return "\@" . $array . $left . $list . $right;
3141 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
3142 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
3147 my $idx = $op->first;
3148 my $list = $op->last;
3150 $list = $self->deparse($list, 1);
3151 $idx = $self->deparse($idx, 1);
3152 return "($list)" . "[$idx]";
3157 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
3162 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
3168 my $kid = $op->first->sibling; # skip pushmark
3169 my($meth, $obj, @exprs);
3170 if ($kid->name eq "list" and want_list $kid) {
3171 # When an indirect object isn't a bareword but the args are in
3172 # parens, the parens aren't part of the method syntax (the LLAFR
3173 # doesn't apply), but they make a list with OPf_PARENS set that
3174 # doesn't get flattened by the append_elem that adds the method,
3175 # making a (object, arg1, arg2, ...) list where the object
3176 # usually is. This can be distinguished from
3177 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
3178 # object) because in the later the list is in scalar context
3179 # as the left side of -> always is, while in the former
3180 # the list is in list context as method arguments always are.
3181 # (Good thing there aren't method prototypes!)
3182 $meth = $kid->sibling;
3183 $kid = $kid->first->sibling; # skip pushmark
3185 $kid = $kid->sibling;
3186 for (; not null $kid; $kid = $kid->sibling) {
3191 $kid = $kid->sibling;
3192 for (; !null ($kid->sibling) && $kid->name ne "method_named";
3193 $kid = $kid->sibling) {
3199 if ($meth->name eq "method_named") {
3200 $meth = $self->const_sv($meth)->PV;
3202 $meth = $meth->first;
3203 if ($meth->name eq "const") {
3204 # As of 5.005_58, this case is probably obsoleted by the
3205 # method_named case above
3206 $meth = $self->const_sv($meth)->PV; # needs to be bare
3210 return { method => $meth, variable_method => ref($meth),
3211 object => $obj, args => \@exprs };
3214 # compat function only
3217 my $info = $self->_method(@_);
3218 return $self->e_method( $self->_method(@_) );
3222 my ($self, $info) = @_;
3223 my $obj = $self->deparse($info->{object}, 24);
3225 my $meth = $info->{method};
3226 $meth = $self->deparse($meth, 1) if $info->{variable_method};
3227 my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
3228 my $kid = $obj . "->" . $meth;
3230 return $kid . "(" . $args . ")"; # parens mandatory
3236 # returns "&" if the prototype doesn't match the args,
3237 # or ("", $args_after_prototype_demunging) if it does.
3240 return "&" if $self->{'noproto'};
3241 my($proto, @args) = @_;
3245 # An unbackslashed @ or % gobbles up the rest of the args
3246 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
3248 $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)//;
3251 return "&" if @args;
3252 } elsif ($chr eq ";") {
3254 } elsif ($chr eq "@" or $chr eq "%") {
3255 push @reals, map($self->deparse($_, 6), @args);
3260 if ($chr eq "\$" || $chr eq "_") {
3261 if (want_scalar $arg) {
3262 push @reals, $self->deparse($arg, 6);
3266 } elsif ($chr eq "&") {
3267 if ($arg->name =~ /^(s?refgen|undef)$/) {
3268 push @reals, $self->deparse($arg, 6);
3272 } elsif ($chr eq "*") {
3273 if ($arg->name =~ /^s?refgen$/
3274 and $arg->first->first->name eq "rv2gv")
3276 $real = $arg->first->first; # skip refgen, null
3277 if ($real->first->name eq "gv") {
3278 push @reals, $self->deparse($real, 6);
3280 push @reals, $self->deparse($real->first, 6);
3285 } elsif (substr($chr, 0, 1) eq "\\") {
3287 if ($arg->name =~ /^s?refgen$/ and
3288 !null($real = $arg->first) and
3289 ($chr =~ /\$/ && is_scalar($real->first)
3291 && class($real->first->sibling) ne 'NULL'
3292 && $real->first->sibling->name
3295 && class($real->first->sibling) ne 'NULL'
3296 && $real->first->sibling->name
3298 #or ($chr =~ /&/ # This doesn't work
3299 # && $real->first->name eq "rv2cv")
3301 && $real->first->name eq "rv2gv")))
3303 push @reals, $self->deparse($real, 6);
3310 return "&" if $proto and !$doneok; # too few args and no `;'
3311 return "&" if @args; # too many args
3312 return ("", join ", ", @reals);
3318 return $self->e_method($self->_method($op, $cx))
3319 unless null $op->first->sibling;
3323 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
3325 } elsif ($op->private & OPpENTERSUB_AMPER) {
3329 $kid = $kid->first->sibling; # skip ex-list, pushmark
3330 for (; not null $kid->sibling; $kid = $kid->sibling) {
3335 if (is_scope($kid)) {
3337 $kid = "{" . $self->deparse($kid, 0) . "}";
3338 } elsif ($kid->first->name eq "gv") {
3339 my $gv = $self->gv_or_padgv($kid->first);
3340 if (class($gv->CV) ne "SPECIAL") {
3341 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
3343 $simple = 1; # only calls of named functions can be prototyped
3344 $kid = $self->deparse($kid, 24);
3346 if ($kid eq 'main::') {
3348 } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
3349 $kid = single_delim("q", "'", $kid) . '->';
3352 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
3354 $kid = $self->deparse($kid, 24);
3357 my $arrow = is_subscriptable($kid->first) ? "" : "->";
3358 $kid = $self->deparse($kid, 24) . $arrow;
3361 # Doesn't matter how many prototypes there are, if
3362 # they haven't happened yet!
3366 no warnings 'uninitialized';
3367 $declared = exists $self->{'subs_declared'}{$kid}
3369 defined &{ ${$self->{'curstash'}."::"}{$kid} }
3371 $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
3372 && defined prototype $self->{'curstash'}."::".$kid
3374 if (!$declared && defined($proto)) {
3375 # Avoid "too early to check prototype" warning
3376 ($amper, $proto) = ('&');
3381 if ($declared and defined $proto and not $amper) {
3382 ($amper, $args) = $self->check_proto($proto, @exprs);
3383 if ($amper eq "&") {
3384 $args = join(", ", map($self->deparse($_, 6), @exprs));
3387 $args = join(", ", map($self->deparse($_, 6), @exprs));
3389 if ($prefix or $amper) {
3390 if ($op->flags & OPf_STACKED) {
3391 return $prefix . $amper . $kid . "(" . $args . ")";
3393 return $prefix . $amper. $kid;
3396 # glob() invocations can be translated into calls of
3397 # CORE::GLOBAL::glob with a second parameter, a number.
3399 if ($kid eq "CORE::GLOBAL::glob") {
3401 $args =~ s/\s*,[^,]+$//;
3404 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
3405 # so it must have been translated from a keyword call. Translate
3407 $kid =~ s/^CORE::GLOBAL:://;
3409 my $dproto = defined($proto) ? $proto : "undefined";
3411 return "$kid(" . $args . ")";
3412 } elsif ($dproto eq "") {
3414 } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
3415 # is_scalar is an excessively conservative test here:
3416 # really, we should be comparing to the precedence of the
3417 # top operator of $exprs[0] (ala unop()), but that would
3418 # take some major code restructuring to do right.
3419 return $self->maybe_parens_func($kid, $args, $cx, 16);
3420 } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
3421 return $self->maybe_parens_func($kid, $args, $cx, 5);
3423 return "$kid(" . $args . ")";
3428 sub pp_enterwrite { unop(@_, "write") }
3430 # escape things that cause interpolation in double quotes,
3431 # but not character escapes
3434 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
3442 # Matches any string which is balanced with respect to {braces}
3453 # the same, but treat $|, $), $( and $ at the end of the string differently
3467 (\(\?\??\{$bal\}\)) # $4
3473 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3478 # This is for regular expressions with the /x modifier
3479 # We have to leave comments unmangled.
3480 sub re_uninterp_extended {
3493 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
3494 | \#[^\n]* # (skip over comments)
3501 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3507 my %unctrl = # portable to to EBCDIC
3509 "\c@" => '\c@', # unused
3536 "\c[" => '\c[', # unused
3537 "\c\\" => '\c\\', # unused
3538 "\c]" => '\c]', # unused
3539 "\c_" => '\c_', # unused
3542 # character escapes, but not delimiters that might need to be escaped
3543 sub escape_str { # ASCII, UTF8
3545 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3547 # $str =~ s/\cH/\\b/g; # \b means something different in a regex
3553 $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
3554 $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
3558 # For regexes with the /x modifier.
3559 # Leave whitespace unmangled.
3560 sub escape_extended_re {
3562 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3563 $str =~ s/([[:^print:]])/
3564 ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
3565 $str =~ s/\n/\n\f/g;
3569 # Don't do this for regexen
3572 $str =~ s/\\/\\\\/g;
3576 # Remove backslashes which precede literal control characters,
3577 # to avoid creating ambiguity when we escape the latter.
3581 # the insane complexity here is due to the behaviour of "\c\"
3582 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
3586 sub balanced_delim {
3588 my @str = split //, $str;
3589 my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
3590 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3591 ($open, $close) = @$ar;
3592 $fail = 0; $cnt = 0; $last_bs = 0;
3595 $fail = 1 if $last_bs;
3597 } elsif ($c eq $close) {
3598 $fail = 1 if $last_bs;
3606 $last_bs = $c eq '\\';
3608 $fail = 1 if $cnt != 0;
3609 return ($open, "$open$str$close") if not $fail;
3615 my($q, $default, $str) = @_;
3616 return "$default$str$default" if $default and index($str, $default) == -1;
3618 (my $succeed, $str) = balanced_delim($str);
3619 return "$q$str" if $succeed;
3621 for my $delim ('/', '"', '#') {
3622 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3625 $str =~ s/$default/\\$default/g;
3626 return "$default$str$default";
3634 BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
3636 # Split a floating point number into an integer mantissa and a binary
3637 # exponent. Assumes you've already made sure the number isn't zero or
3638 # some weird infinity or NaN.
3642 if ($f == int($f)) {
3643 while ($f % 2 == 0) {
3648 while ($f != int($f)) {
3653 my $mantissa = sprintf("%.0f", $f);
3654 return ($mantissa, $exponent);
3660 if ($self->{'use_dumper'}) {
3661 return $self->const_dumper($sv, $cx);
3663 if (class($sv) eq "SPECIAL") {
3664 # sv_undef, sv_yes, sv_no
3665 return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
3667 if (class($sv) eq "NULL") {
3670 # convert a version object into the "v1.2.3" string in its V magic
3671 if ($sv->FLAGS & SVs_RMG) {
3672 for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
3673 return $mg->PTR if $mg->TYPE eq 'V';
3677 if ($sv->FLAGS & SVf_IOK) {
3678 my $str = $sv->int_value;
3679 $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
3681 } elsif ($sv->FLAGS & SVf_NOK) {
3684 if (pack("F", $nv) eq pack("F", 0)) {
3689 return $self->maybe_parens("-.0", $cx, 21);
3691 } elsif (1/$nv == 0) {
3694 return $self->maybe_parens("9**9**9", $cx, 22);
3697 return $self->maybe_parens("-9**9**9", $cx, 21);
3699 } elsif ($nv != $nv) {
3701 if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
3703 return "sin(9**9**9)";
3704 } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
3706 return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
3709 my $hex = unpack("h*", pack("F", $nv));
3710 return qq'unpack("F", pack("h*", "$hex"))';
3713 # first, try the default stringification
3716 # failing that, try using more precision
3717 $str = sprintf("%.${max_prec}g", $nv);
3718 # if (pack("F", $str) ne pack("F", $nv)) {
3720 # not representable in decimal with whatever sprintf()
3721 # and atof() Perl is using here.
3722 my($mant, $exp) = split_float($nv);
3723 return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
3726 $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
3728 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3730 if (class($ref) eq "AV") {
3731 return "[" . $self->list_const(2, $ref->ARRAY) . "]";
3732 } elsif (class($ref) eq "HV") {
3733 my %hash = $ref->ARRAY;
3735 for my $k (sort keys %hash) {
3736 push @elts, "$k => " . $self->const($hash{$k}, 6);
3738 return "{" . join(", ", @elts) . "}";
3739 } elsif (class($ref) eq "CV") {
3740 return "sub " . $self->deparse_sub($ref);
3742 if ($ref->FLAGS & SVs_SMG) {
3743 for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
3744 if ($mg->TYPE eq 'r') {
3745 my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
3746 return single_delim("qr", "", $re);
3751 return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
3752 } elsif ($sv->FLAGS & SVf_POK) {
3754 if ($str =~ /[[:^print:]]/) {
3755 return single_delim("qq", '"', uninterp escape_str unback $str);
3757 return single_delim("q", "'", unback $str);
3767 my $ref = $sv->object_2svref();
3768 my $dumper = Data::Dumper->new([$$ref], ['$v']);
3769 $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
3770 my $str = $dumper->Dump();
3771 if ($str =~ /^\$v/) {
3772 return '${my ' . $str . ' \$v}';
3782 # the constant could be in the pad (under useithreads)
3783 $sv = $self->padval($op->targ) unless $$sv;
3790 if ($op->private & OPpCONST_ARYBASE) {
3793 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3794 # return $self->const_sv($op)->PV;
3796 my $sv = $self->const_sv($op);
3797 return $self->const($sv, $cx);
3803 my $type = $op->name;
3804 if ($type eq "const") {
3805 return '$[' if $op->private & OPpCONST_ARYBASE;
3806 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3807 } elsif ($type eq "concat") {
3808 my $first = $self->dq($op->first);
3809 my $last = $self->dq($op->last);
3811 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
3812 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3813 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
3814 || ($last =~ /^[:'{\[\w_]/ && #'
3815 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3817 return $first . $last;
3818 } elsif ($type eq "uc") {
3819 return '\U' . $self->dq($op->first->sibling) . '\E';
3820 } elsif ($type eq "lc") {
3821 return '\L' . $self->dq($op->first->sibling) . '\E';
3822 } elsif ($type eq "ucfirst") {
3823 return '\u' . $self->dq($op->first->sibling);
3824 } elsif ($type eq "lcfirst") {
3825 return '\l' . $self->dq($op->first->sibling);
3826 } elsif ($type eq "quotemeta") {
3827 return '\Q' . $self->dq($op->first->sibling) . '\E';
3828 } elsif ($type eq "join") {
3829 return $self->deparse($op->last, 26); # was join($", @ary)
3831 return $self->deparse($op, 26);
3838 # skip pushmark if it exists (readpipe() vs ``)
3839 my $child = $op->first->sibling->isa('B::NULL')
3840 ? $op->first : $op->first->sibling;
3841 return single_delim("qx", '`', $self->dq($child));
3847 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3848 return $self->deparse($kid, $cx) if $self->{'unquote'};
3849 $self->maybe_targmy($kid, $cx,
3850 sub {single_delim("qq", '"', $self->dq($_[1]))});
3853 # OP_STRINGIFY is a listop, but it only ever has one arg
3854 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3856 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3857 # note that tr(from)/to/ is OK, but not tr/from/(to)
3859 my($from, $to) = @_;
3860 my($succeed, $delim);
3861 if ($from !~ m[/] and $to !~ m[/]) {
3862 return "/$from/$to/";
3863 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3864 if (($succeed, $to) = balanced_delim($to) and $succeed) {
3867 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3868 return "$from$delim$to$delim" if index($to, $delim) == -1;
3871 return "$from/$to/";
3874 for $delim ('/', '"', '#') { # note no '
3875 return "$delim$from$delim$to$delim"
3876 if index($to . $from, $delim) == -1;
3878 $from =~ s[/][\\/]g;
3880 return "/$from/$to/";
3884 # Only used by tr///, so backslashes hyphens
3887 if ($n == ord '\\') {
3889 } elsif ($n == ord "-") {
3891 } elsif ($n >= ord(' ') and $n <= ord('~')) {
3893 } elsif ($n == ord "\a") {
3895 } elsif ($n == ord "\b") {
3897 } elsif ($n == ord "\t") {
3899 } elsif ($n == ord "\n") {
3901 } elsif ($n == ord "\e") {
3903 } elsif ($n == ord "\f") {
3905 } elsif ($n == ord "\r") {
3907 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3908 return '\\c' . chr(ord("@") + $n);
3910 # return '\x' . sprintf("%02x", $n);
3911 return '\\' . sprintf("%03o", $n);
3917 my($str, $c, $tr) = ("");
3918 for ($c = 0; $c < @chars; $c++) {
3921 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3922 $chars[$c + 2] == $tr + 2)
3924 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3927 $str .= pchr($chars[$c]);
3933 sub tr_decode_byte {
3934 my($table, $flags) = @_;
3935 my(@table) = unpack("s*", $table);
3936 splice @table, 0x100, 1; # Number of subsequent elements
3937 my($c, $tr, @from, @to, @delfrom, $delhyphen);
3938 if ($table[ord "-"] != -1 and
3939 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3941 $tr = $table[ord "-"];
3942 $table[ord "-"] = -1;
3946 } else { # -2 ==> delete
3950 for ($c = 0; $c < @table; $c++) {
3953 push @from, $c; push @to, $tr;
3954 } elsif ($tr == -2) {
3958 @from = (@from, @delfrom);
3959 if ($flags & OPpTRANS_COMPLEMENT) {
3962 @from{@from} = (1) x @from;
3963 for ($c = 0; $c < 256; $c++) {
3964 push @newfrom, $c unless $from{$c};
3968 unless ($flags & OPpTRANS_DELETE || !@to) {
3969 pop @to while $#to and $to[$#to] == $to[$#to -1];
3972 $from = collapse(@from);
3973 $to = collapse(@to);
3974 $from .= "-" if $delhyphen;
3975 return ($from, $to);
3980 if ($x == ord "-") {
3982 } elsif ($x == ord "\\") {
3989 # XXX This doesn't yet handle all cases correctly either
3991 sub tr_decode_utf8 {
3992 my($swash_hv, $flags) = @_;
3993 my %swash = $swash_hv->ARRAY;
3995 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3996 my $none = $swash{"NONE"}->IV;
3997 my $extra = $none + 1;
3998 my(@from, @delfrom, @to);
4000 foreach $line (split /\n/, $swash{'LIST'}->PV) {
4001 my($min, $max, $result) = split(/\t/, $line);
4008 $result = hex $result;
4009 if ($result == $extra) {
4010 push @delfrom, [$min, $max];
4012 push @from, [$min, $max];
4013 push @to, [$result, $result + $max - $min];
4016 for my $i (0 .. $#from) {
4017 if ($from[$i][0] == ord '-') {
4018 unshift @from, splice(@from, $i, 1);
4019 unshift @to, splice(@to, $i, 1);
4021 } elsif ($from[$i][1] == ord '-') {
4024 unshift @from, ord '-';
4025 unshift @to, ord '-';
4029 for my $i (0 .. $#delfrom) {
4030 if ($delfrom[$i][0] == ord '-') {
4031 push @delfrom, splice(@delfrom, $i, 1);
4033 } elsif ($delfrom[$i][1] == ord '-') {
4035 push @delfrom, ord '-';
4039 if (defined $final and $to[$#to][1] != $final) {
4040 push @to, [$final, $final];
4042 push @from, @delfrom;
4043 if ($flags & OPpTRANS_COMPLEMENT) {
4046 for my $i (0 .. $#from) {
4047 push @newfrom, [$next, $from[$i][0] - 1];
4048 $next = $from[$i][1] + 1;
4051 for my $range (@newfrom) {
4052 if ($range->[0] <= $range->[1]) {
4057 my($from, $to, $diff);
4058 for my $chunk (@from) {
4059 $diff = $chunk->[1] - $chunk->[0];
4061 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
4062 } elsif ($diff == 1) {
4063 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
4065 $from .= tr_chr($chunk->[0]);
4068 for my $chunk (@to) {
4069 $diff = $chunk->[1] - $chunk->[0];
4071 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
4072 } elsif ($diff == 1) {
4073 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
4075 $to .= tr_chr($chunk->[0]);
4078 #$final = sprintf("%04x", $final) if defined $final;
4079 #$none = sprintf("%04x", $none) if defined $none;
4080 #$extra = sprintf("%04x", $extra) if defined $extra;
4081 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
4082 #print STDERR $swash{'LIST'}->PV;
4083 return (escape_str($from), escape_str($to));
4090 my $class = class($op);
4091 my $priv_flags = $op->private;
4092 if ($class eq "PVOP") {
4093 ($from, $to) = tr_decode_byte($op->pv, $priv_flags);
4094 } elsif ($class eq "PADOP") {
4096 = tr_decode_utf8($self->padval($op->padix)->RV, $priv_flags);
4097 } else { # class($op) eq "SVOP"
4098 ($from, $to) = tr_decode_utf8($op->sv->RV, $priv_flags);
4101 $flags .= "c" if $priv_flags & OPpTRANS_COMPLEMENT;
4102 $flags .= "d" if $priv_flags & OPpTRANS_DELETE;
4103 $to = "" if $from eq $to and $flags eq "";
4104 $flags .= "s" if $priv_flags & OPpTRANS_SQUASH;
4105 return "tr" . double_delim($from, $to) . $flags;
4108 sub pp_transr { &pp_trans . 'r' }
4110 sub re_dq_disambiguate {
4111 my ($first, $last) = @_;
4112 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
4113 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
4114 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
4115 || ($last =~ /^[{\[\w_]/ &&
4116 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
4117 return $first . $last;
4120 # Like dq(), but different
4123 my ($op, $extended) = @_;
4125 my $type = $op->name;
4126 if ($type eq "const") {
4127 return '$[' if $op->private & OPpCONST_ARYBASE;
4128 my $unbacked = re_unback($self->const_sv($op)->as_string);
4129 return re_uninterp_extended(escape_extended_re($unbacked))
4131 return re_uninterp(escape_str($unbacked));
4132 } elsif ($type eq "concat") {
4133 my $first = $self->re_dq($op->first, $extended);
4134 my $last = $self->re_dq($op->last, $extended);
4135 return re_dq_disambiguate($first, $last);
4136 } elsif ($type eq "uc") {
4137 return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
4138 } elsif ($type eq "lc") {
4139 return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
4140 } elsif ($type eq "ucfirst") {
4141 return '\u' . $self->re_dq($op->first->sibling, $extended);
4142 } elsif ($type eq "lcfirst") {
4143 return '\l' . $self->re_dq($op->first->sibling, $extended);
4144 } elsif ($type eq "quotemeta") {
4145 return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
4146 } elsif ($type eq "join") {
4147 return $self->deparse($op->last, 26); # was join($", @ary)
4149 return $self->deparse($op, 26);
4154 my ($self, $op) = @_;
4155 return 0 if null $op;
4156 my $type = $op->name;
4158 if ($type eq 'const') {
4161 elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
4162 return $self->pure_string($op->first->sibling);
4164 elsif ($type eq 'join') {
4165 my $join_op = $op->first->sibling; # Skip pushmark
4166 return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
4168 my $gvop = $join_op->first;
4169 return 0 unless $gvop->name eq 'gvsv';
4170 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
4172 return 0 unless ${$join_op->sibling} eq ${$op->last};
4173 return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
4175 elsif ($type eq 'concat') {
4176 return $self->pure_string($op->first)
4177 && $self->pure_string($op->last);
4179 elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
4182 elsif ($type eq "null" and $op->can('first') and not null $op->first and
4183 $op->first->name eq "null" and $op->first->can('first')
4184 and not null $op->first->first and
4185 $op->first->first->name eq "aelemfast") {
4197 my($op, $cx, $extended) = @_;
4198 my $kid = $op->first;
4199 $kid = $kid->first if $kid->name eq "regcmaybe";
4200 $kid = $kid->first if $kid->name eq "regcreset";
4201 if ($kid->name eq "null" and !null($kid->first)
4202 and $kid->first->name eq 'pushmark')
4205 $kid = $kid->first->sibling;
4206 while (!null($kid)) {
4208 my $last = $self->re_dq($kid, $extended);
4209 $str = re_dq_disambiguate($first, $last);
4210 $kid = $kid->sibling;
4215 return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
4216 return ($self->deparse($kid, $cx), 0);
4220 my ($self, $op, $cx) = @_;
4221 return (($self->regcomp($op, $cx, 0))[0]);
4224 # osmic acid -- see osmium tetroxide
4227 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
4228 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
4229 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
4233 my($op, $cx, $name, $delim) = @_;
4234 my $kid = $op->first;
4235 my ($binop, $var, $re) = ("", "", "");
4236 if ($op->flags & OPf_STACKED) {
4238 $var = $self->deparse($kid, 20);
4239 $kid = $kid->sibling;
4242 my $extended = ($op->pmflags & PMf_EXTENDED);
4243 my $rhs_bound_to_defsv;
4245 my $unbacked = re_unback($op->precomp);
4247 $re = re_uninterp_extended(escape_extended_re($unbacked));
4249 $re = re_uninterp(escape_str(re_unback($op->precomp)));
4251 } elsif ($kid->name ne 'regcomp') {
4252 carp("found ".$kid->name." where regcomp expected");
4254 ($re, $quote) = $self->regcomp($kid, 21, $extended);
4255 $rhs_bound_to_defsv = 1 if $kid->first->first->flags & OPf_SPECIAL;
4258 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
4259 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
4260 $flags .= "i" if $op->pmflags & PMf_FOLD;
4261 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
4262 $flags .= "o" if $op->pmflags & PMf_KEEP;
4263 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
4264 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
4265 $flags = $matchwords{$flags} if $matchwords{$flags};
4266 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
4270 $re = single_delim($name, $delim, $re);
4272 $re = $re . $flags if $quote;
4275 $self->maybe_parens(
4277 ? "$var =~ (\$_ =~ $re)"
4286 sub pp_match { matchop(@_, "m", "/") }
4287 sub pp_pushre { matchop(@_, "m", "/") }
4288 sub pp_qr { matchop(@_, "qr", "") }
4293 my($kid, @exprs, $ary, $expr);
4296 # For our kid (an OP_PUSHRE), pmreplroot is never actually the
4297 # root of a replacement; it's either empty, or abused to point to
4298 # the GV for an array we split into (an optimization to save
4299 # assignment overhead). Depending on whether we're using ithreads,
4300 # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
4301 # figures out for us which it is.
4302 my $replroot = $kid->pmreplroot;
4304 if (ref($replroot) eq "B::GV") {
4306 } elsif (!ref($replroot) and $replroot > 0) {
4307 $gv = $self->padval($replroot);
4309 $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
4311 for (; !null($kid); $kid = $kid->sibling) {
4312 push @exprs, $self->deparse($kid, 6);
4315 # handle special case of split(), and split(' ') that compiles to /\s+/
4316 # Under 5.10, the reflags may be undef if the split regexp isn't a constant
4318 if ( $kid->flags & OPf_SPECIAL
4319 and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
4320 : ($kid->reflags || 0) & RXf_SKIPWHITE() ) ) {
4324 $expr = "split(" . join(", ", @exprs) . ")";
4326 return $self->maybe_parens("$ary = $expr", $cx, 7);
4332 # oxime -- any of various compounds obtained chiefly by the action of
4333 # hydroxylamine on aldehydes and ketones and characterized by the
4334 # bivalent grouping C=NOH [Webster's Tenth]
4337 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
4338 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
4339 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
4340 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi',
4341 'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime',
4342 'or', 'rose', 'rosie');
4347 my $kid = $op->first;
4348 my($binop, $var, $re, $repl) = ("", "", "", "");
4349 if ($op->flags & OPf_STACKED) {
4351 $var = $self->deparse($kid, 20);
4352 $kid = $kid->sibling;
4355 if (null($op->pmreplroot)) {
4356 $repl = $self->dq($kid);
4357 $kid = $kid->sibling;
4359 $repl = $op->pmreplroot->first; # skip substcont
4360 while ($repl->name eq "entereval") {
4361 $repl = $repl->first;
4364 if ($op->pmflags & PMf_EVAL) {
4365 $repl = $self->deparse($repl->first, 0);
4367 $repl = $self->dq($repl);
4370 my $extended = ($op->pmflags & PMf_EXTENDED);
4372 my $unbacked = re_unback($op->precomp);
4374 $re = re_uninterp_extended(escape_extended_re($unbacked));
4377 $re = re_uninterp(escape_str($unbacked));
4380 ($re) = $self->regcomp($kid, 1, $extended);
4382 $flags .= "e" if $op->pmflags & PMf_EVAL;
4383 $flags .= "r" if $op->pmflags & PMf_NONDESTRUCT;
4384 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
4385 $flags .= "i" if $op->pmflags & PMf_FOLD;
4386 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
4387 $flags .= "o" if $op->pmflags & PMf_KEEP;
4388 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
4389 $flags .= "x" if $extended;
4390 $flags = $substwords{$flags} if $substwords{$flags};
4392 return $self->maybe_parens("$var =~ s"
4393 . double_delim($re, $repl) . $flags,
4396 return "s". double_delim($re, $repl) . $flags;
4405 B::Deparse - Perl compiler backend to produce perl code
4409 B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
4410 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
4414 B::Deparse is a backend module for the Perl compiler that generates
4415 perl source code, based on the internal compiled structure that perl
4416 itself creates after parsing a program. The output of B::Deparse won't
4417 be exactly the same as the original source, since perl doesn't keep
4418 track of comments or whitespace, and there isn't a one-to-one
4419 correspondence between perl's syntactical constructions and their
4420 compiled form, but it will often be close. When you use the B<-p>
4421 option, the output also includes parentheses even when they are not
4422 required by precedence, which can make it easy to see if perl is
4423 parsing your expressions the way you intended.
4425 While B::Deparse goes to some lengths to try to figure out what your
4426 original program was doing, some parts of the language can still trip
4427 it up; it still fails even on some parts of Perl's own test suite. If
4428 you encounter a failure other than the most common ones described in
4429 the BUGS section below, you can help contribute to B::Deparse's
4430 ongoing development by submitting a bug report with a small
4435 As with all compiler backend options, these must follow directly after
4436 the '-MO=Deparse', separated by a comma but not any white space.
4442 Output data values (when they appear as constants) using Data::Dumper.
4443 Without this option, B::Deparse will use some simple routines of its
4444 own for the same purpose. Currently, Data::Dumper is better for some
4445 kinds of data (such as complex structures with sharing and
4446 self-reference) while the built-in routines are better for others
4447 (such as odd floating-point values).
4451 Normally, B::Deparse deparses the main code of a program, and all the subs
4452 defined in the same file. To include subs defined in other files, pass the
4453 B<-f> option with the filename. You can pass the B<-f> option several times, to
4454 include more than one secondary file. (Most of the time you don't want to
4455 use it at all.) You can also use this option to include subs which are
4456 defined in the scope of a B<#line> directive with two parameters.
4460 Add '#line' declarations to the output based on the line and file
4461 locations of the original code.
4465 Print extra parentheses. Without this option, B::Deparse includes
4466 parentheses in its output only when they are needed, based on the
4467 structure of your program. With B<-p>, it uses parentheses (almost)
4468 whenever they would be legal. This can be useful if you are used to
4469 LISP, or if you want to see how perl parses your input. If you say
4471 if ($var & 0x7f == 65) {print "Gimme an A!"}
4472 print ($which ? $a : $b), "\n";
4473 $name = $ENV{USER} or "Bob";
4475 C<B::Deparse,-p> will print
4478 print('Gimme an A!')
4480 (print(($which ? $a : $b)), '???');
4481 (($name = $ENV{'USER'}) or '???')
4483 which probably isn't what you intended (the C<'???'> is a sign that
4484 perl optimized away a constant value).
4488 Disable prototype checking. With this option, all function calls are
4489 deparsed as if no prototype was defined for them. In other words,
4491 perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
4500 making clear how the parameters are actually passed to C<foo>.
4504 Expand double-quoted strings into the corresponding combinations of
4505 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
4508 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
4512 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
4513 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
4515 Note that the expanded form represents the way perl handles such
4516 constructions internally -- this option actually turns off the reverse
4517 translation that B::Deparse usually does. On the other hand, note that
4518 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
4519 of $y into a string before doing the assignment.
4521 =item B<-s>I<LETTERS>
4523 Tweak the style of B::Deparse's output. The letters should follow
4524 directly after the 's', with no space or punctuation. The following
4525 options are available:
4531 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
4548 The default is not to cuddle.
4552 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
4556 Use tabs for each 8 columns of indent. The default is to use only spaces.
4557 For instance, if the style options are B<-si4T>, a line that's indented
4558 3 times will be preceded by one tab and four spaces; if the options were
4559 B<-si8T>, the same line would be preceded by three tabs.
4561 =item B<v>I<STRING>B<.>
4563 Print I<STRING> for the value of a constant that can't be determined
4564 because it was optimized away (mnemonic: this happens when a constant
4565 is used in B<v>oid context). The end of the string is marked by a period.
4566 The string should be a valid perl expression, generally a constant.
4567 Note that unless it's a number, it probably needs to be quoted, and on
4568 a command line quotes need to be protected from the shell. Some
4569 conventional values include 0, 1, 42, '', 'foo', and
4570 'Useless use of constant omitted' (which may need to be
4571 B<-sv"'Useless use of constant omitted'.">
4572 or something similar depending on your shell). The default is '???'.
4573 If you're using B::Deparse on a module or other file that's require'd,
4574 you shouldn't use a value that evaluates to false, since the customary
4575 true constant at the end of a module will be in void context when the
4576 file is compiled as a main program.
4582 Expand conventional syntax constructions into equivalent ones that expose
4583 their internal operation. I<LEVEL> should be a digit, with higher values
4584 meaning more expansion. As with B<-q>, this actually involves turning off
4585 special cases in B::Deparse's normal operations.
4587 If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
4588 while loops with continue blocks; for instance
4590 for ($i = 0; $i < 10; ++$i) {
4603 Note that in a few cases this translation can't be perfectly carried back
4604 into the source code -- if the loop's initializer declares a my variable,
4605 for instance, it won't have the correct scope outside of the loop.
4607 If I<LEVEL> is at least 5, C<use> declarations will be translated into
4608 C<BEGIN> blocks containing calls to C<require> and C<import>; for
4618 'strict'->import('refs')
4622 If I<LEVEL> is at least 7, C<if> statements will be translated into
4623 equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
4625 print 'hi' if $nice;
4637 $nice and print 'hi';
4638 $nice and do { print 'hi' };
4639 $nice ? do { print 'hi' } : do { print 'bye' };
4641 Long sequences of elsifs will turn into nested ternary operators, which
4642 B::Deparse doesn't know how to indent nicely.
4646 =head1 USING B::Deparse AS A MODULE
4651 $deparse = B::Deparse->new("-p", "-sC");
4652 $body = $deparse->coderef2text(\&func);
4653 eval "sub func $body"; # the inverse operation
4657 B::Deparse can also be used on a sub-by-sub basis from other perl
4662 $deparse = B::Deparse->new(OPTIONS)
4664 Create an object to store the state of a deparsing operation and any
4665 options. The options are the same as those that can be given on the
4666 command line (see L</OPTIONS>); options that are separated by commas
4667 after B<-MO=Deparse> should be given as separate strings.
4669 =head2 ambient_pragmas
4671 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
4673 The compilation of a subroutine can be affected by a few compiler
4674 directives, B<pragmas>. These are:
4688 Assigning to the special variable $[
4708 Ordinarily, if you use B::Deparse on a subroutine which has
4709 been compiled in the presence of one or more of these pragmas,
4710 the output will include statements to turn on the appropriate
4711 directives. So if you then compile the code returned by coderef2text,
4712 it will behave the same way as the subroutine which you deparsed.
4714 However, you may know that you intend to use the results in a
4715 particular context, where some pragmas are already in scope. In
4716 this case, you use the B<ambient_pragmas> method to describe the
4717 assumptions you wish to make.
4719 Not all of the options currently have any useful effect. See
4720 L</BUGS> for more details.
4722 The parameters it accepts are:
4728 Takes a string, possibly containing several values separated
4729 by whitespace. The special values "all" and "none" mean what you'd
4732 $deparse->ambient_pragmas(strict => 'subs refs');
4736 Takes a number, the value of the array base $[.
4744 If the value is true, then the appropriate pragma is assumed to
4745 be in the ambient scope, otherwise not.
4749 Takes a string, possibly containing a whitespace-separated list of
4750 values. The values "all" and "none" are special. It's also permissible
4751 to pass an array reference here.
4753 $deparser->ambient_pragmas(re => 'eval');
4758 Takes a string, possibly containing a whitespace-separated list of
4759 values. The values "all" and "none" are special, again. It's also
4760 permissible to pass an array reference here.
4762 $deparser->ambient_pragmas(warnings => [qw[void io]]);
4764 If one of the values is the string "FATAL", then all the warnings
4765 in that list will be considered fatal, just as with the B<warnings>
4766 pragma itself. Should you need to specify that some warnings are
4767 fatal, and others are merely enabled, you can pass the B<warnings>
4770 $deparser->ambient_pragmas(
4772 warnings => [FATAL => qw/void io/],
4775 See L<perllexwarn> for more information about lexical warnings.
4781 These two parameters are used to specify the ambient pragmas in
4782 the format used by the special variables $^H and ${^WARNING_BITS}.
4784 They exist principally so that you can write code like:
4786 { my ($hint_bits, $warning_bits);
4787 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
4788 $deparser->ambient_pragmas (
4789 hint_bits => $hint_bits,
4790 warning_bits => $warning_bits,
4794 which specifies that the ambient pragmas are exactly those which
4795 are in scope at the point of calling.
4799 This parameter is used to specify the ambient pragmas which are
4800 stored in the special hash %^H.
4806 $body = $deparse->coderef2text(\&func)
4807 $body = $deparse->coderef2text(sub ($$) { ... })
4809 Return source code for the body of a subroutine (a block, optionally
4810 preceded by a prototype in parens), given a reference to the
4811 sub. Because a subroutine can have no names, or more than one name,
4812 this method doesn't return a complete subroutine definition -- if you
4813 want to eval the result, you should prepend "sub subname ", or "sub "
4814 for an anonymous function constructor. Unless the sub was defined in
4815 the main:: package, the code will include a package declaration.
4823 The only pragmas to be completely supported are: C<use warnings>,
4824 C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
4825 behaves like a pragma, is also supported.)
4827 Excepting those listed above, we're currently unable to guarantee that
4828 B::Deparse will produce a pragma at the correct point in the program.
4829 (Specifically, pragmas at the beginning of a block often appear right
4830 before the start of the block instead.)
4831 Since the effects of pragmas are often lexically scoped, this can mean
4832 that the pragma holds sway over a different portion of the program
4833 than in the input file.
4837 In fact, the above is a specific instance of a more general problem:
4838 we can't guarantee to produce BEGIN blocks or C<use> declarations in
4839 exactly the right place. So if you use a module which affects compilation
4840 (such as by over-riding keywords, overloading constants or whatever)
4841 then the output code might not work as intended.
4843 This is the most serious outstanding problem, and will require some help
4844 from the Perl core to fix.
4848 If a keyword is over-ridden, and your program explicitly calls
4849 the built-in version by using CORE::keyword, the output of B::Deparse
4850 will not reflect this. If you run the resulting code, it will call
4851 the over-ridden version rather than the built-in one. (Maybe there
4852 should be an option to B<always> print keyword calls as C<CORE::name>.)
4856 Some constants don't print correctly either with or without B<-d>.
4857 For instance, neither B::Deparse nor Data::Dumper know how to print
4858 dual-valued scalars correctly, as in:
4860 use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
4862 use constant H => { "#" => 1 }; H->{"#"};
4866 An input file that uses source filtering probably won't be deparsed into
4867 runnable code, because it will still include the B<use> declaration
4868 for the source filtering module, even though the code that is
4869 produced is already ordinary Perl which shouldn't be filtered again.
4873 Optimised away statements are rendered as '???'. This includes statements that
4874 have a compile-time side-effect, such as the obscure
4878 which is not, consequently, deparsed correctly.
4880 foreach my $i (@_) { 0 }
4882 foreach my $i (@_) { '???' }
4886 Lexical (my) variables declared in scopes external to a subroutine
4887 appear in code2ref output text as package variables. This is a tricky
4888 problem, as perl has no native facility for referring to a lexical variable
4889 defined within a different scope, although L<PadWalker> is a good start.
4893 There are probably many more bugs on non-ASCII platforms (EBCDIC).
4899 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
4900 by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
4901 Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
4902 Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael