2 # Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant.
4 # This module is free software; you can redistribute and/or modify
5 # it under the same terms as Perl itself.
7 # This is based on the module of the same name by Malcolm Beattie,
8 # but essentially none of his code remains.
12 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
13 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
14 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPpPAD_STATE
15 OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
16 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
17 OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
18 OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
19 OPpREVERSE_INPLACE OPpCONST_NOVER
20 SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
22 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_NONDESTRUCT
23 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
24 ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE'),
25 ($] < 5.011 ? 'CVf_LOCKED' : ());
28 use vars qw/$AUTOLOAD/;
32 # Easiest way to keep this code portable between 5.12.x and 5.10.x looks to
33 # be to fake up a dummy CVf_LOCKED that will never actually be true.
34 *CVf_LOCKED = sub () {0} unless defined &CVf_LOCKED;
37 # Changes between 0.50 and 0.51:
38 # - fixed nulled leave with live enter in sort { }
39 # - fixed reference constants (\"str")
40 # - handle empty programs gracefully
41 # - handle infinte loops (for (;;) {}, while (1) {})
42 # - differentiate between `for my $x ...' and `my $x; for $x ...'
43 # - various minor cleanups
44 # - moved globals into an object
45 # - added `-u', like B::C
46 # - package declarations using cop_stash
47 # - subs, formats and code sorted by cop_seq
48 # Changes between 0.51 and 0.52:
49 # - added pp_threadsv (special variables under USE_5005THREADS)
50 # - added documentation
51 # Changes between 0.52 and 0.53:
52 # - many changes adding precedence contexts and associativity
53 # - added `-p' and `-s' output style options
54 # - various other minor fixes
55 # Changes between 0.53 and 0.54:
56 # - added support for new `for (1..100)' optimization,
58 # Changes between 0.54 and 0.55:
59 # - added support for new qr// construct
60 # - added support for new pp_regcreset OP
61 # Changes between 0.55 and 0.56:
62 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
63 # - fixed $# on non-lexicals broken in last big rewrite
64 # - added temporary fix for change in opcode of OP_STRINGIFY
65 # - fixed problem in 0.54's for() patch in `for (@ary)'
66 # - fixed precedence in conditional of ?:
67 # - tweaked list paren elimination in `my($x) = @_'
68 # - made continue-block detection trickier wrt. null ops
69 # - fixed various prototype problems in pp_entersub
70 # - added support for sub prototypes that never get GVs
71 # - added unquoting for special filehandle first arg in truncate
72 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
73 # - added semicolons at the ends of blocks
74 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
75 # Changes between 0.56 and 0.561:
76 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
77 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
78 # Changes between 0.561 and 0.57:
79 # - stylistic changes to symbolic constant stuff
80 # - handled scope in s///e replacement code
81 # - added unquote option for expanding "" into concats, etc.
82 # - split method and proto parts of pp_entersub into separate functions
83 # - various minor cleanups
85 # - added parens in \&foo (patch by Albert Dvornik)
86 # Changes between 0.57 and 0.58:
87 # - fixed `0' statements that weren't being printed
88 # - added methods for use from other programs
89 # (based on patches from James Duncan and Hugo van der Sanden)
90 # - added -si and -sT to control indenting (also based on a patch from Hugo)
91 # - added -sv to print something else instead of '???'
92 # - preliminary version of utf8 tr/// handling
94 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
95 # - added support for Hugo's new OP_SETSTATE (like nextstate)
96 # Changes between 0.58 and 0.59
97 # - added support for Chip's OP_METHOD_NAMED
98 # - added support for Ilya's OPpTARGET_MY optimization
99 # - elided arrows before `()' subscripts when possible
100 # Changes between 0.59 and 0.60
101 # - support for method attribues was added
102 # - some warnings fixed
103 # - separate recognition of constant subs
104 # - rewrote continue block handling, now recoginizing for loops
105 # - added more control of expanding control structures
106 # Changes between 0.60 and 0.61 (mostly by Robin Houston)
108 # - support for pragmas and 'use'
109 # - support for the little-used $[ variable
110 # - support for __DATA__ sections
112 # - BEGIN, CHECK, INIT and END blocks
113 # - scoping of subroutine declarations fixed
114 # - compile-time output from the input program can be suppressed, so that the
115 # output is just the deparsed code. (a change to O.pm in fact)
116 # - our() declarations
117 # - *all* the known bugs are now listed in the BUGS section
118 # - comprehensive test mechanism (TEST -deparse)
119 # Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
122 # - support for command-line switches (-l, -0, etc.)
123 # Changes between 0.63 and 0.64
124 # - support for //, CHECK blocks, and assertions
125 # - improved handling of foreach loops and lexicals
126 # - option to use Data::Dumper for constants
128 # - discovered lots more bugs not yet fixed
132 # Changes between 0.72 and 0.73
133 # - support new switch constructs
136 # (See also BUGS section at the end of this file)
138 # - finish tr/// changes
139 # - add option for even more parens (generalize \&foo change)
140 # - left/right context
141 # - copy comments (look at real text with $^P?)
142 # - avoid semis in one-statement blocks
143 # - associativity of &&=, ||=, ?:
144 # - ',' => '=>' (auto-unquote?)
145 # - break long lines ("\r" as discretionary break?)
146 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
147 # - more style options: brace style, hex vs. octal, quotes, ...
148 # - print big ints as hex/octal instead of decimal (heuristic?)
149 # - handle `my $x if 0'?
150 # - version using op_next instead of op_first/sibling?
151 # - avoid string copies (pass arrays, one big join?)
154 # Current test.deparse failures
155 # comp/hints 6 - location of BEGIN blocks wrt. block openings
156 # run/switchI 1 - missing -I switches entirely
157 # perl -Ifoo -e 'print @INC'
158 # op/caller 2 - warning mask propagates backwards before warnings::register
159 # 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
160 # op/getpid 2 - can't assign to shared my() declaration (threads only)
161 # 'my $x : shared = 5'
162 # op/override 7 - parens on overriden require change v-string interpretation
163 # 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
164 # c.f. 'BEGIN { *f = sub {0} }; f 2'
165 # op/pat 774 - losing Unicode-ness of Latin1-only strings
166 # 'use charnames ":short"; $x="\N{latin:a with acute}"'
167 # op/recurse 12 - missing parens on recursive call makes it look like method
169 # op/subst 90 - inconsistent handling of utf8 under "use utf8"
170 # op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
171 # op/tiehandle compile - "use strict" deparsed in the wrong place
173 # ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
174 # ext/Data/Dumper/t/dumper compile
175 # ext/DB_file/several
177 # ext/Ernno/Errno warnings
178 # ext/IO/lib/IO/t/io_sel 23
179 # ext/PerlIO/t/encoding compile
180 # ext/POSIX/t/posix 6
181 # ext/Socket/Socket 8
182 # ext/Storable/t/croak compile
183 # lib/Attribute/Handlers/t/multi compile
184 # lib/bignum/ several
188 # lib/ExtUtils/t/bytes 4
189 # lib/File/DosGlob compile
190 # lib/Filter/Simple/t/data 1
191 # lib/Math/BigInt/t/constant 1
192 # lib/Net/t/config Deparse-warning
193 # lib/overload compile
194 # lib/Switch/ several
196 # lib/Test/Simple several
198 # lib/Tie/File/t/29_downcopy 5
201 # Object fields (were globals):
204 # (local($a), local($b)) and local($a, $b) have the same internal
205 # representation but the short form looks better. We notice we can
206 # use a large-scale local when checking the list, but need to prevent
207 # individual locals too. This hash holds the addresses of OPs that
208 # have already had their local-ness accounted for. The same thing
212 # CV for current sub (or main program) being deparsed
215 # Cached hash of lexical variables for curcv: keys are names,
216 # each value is an array of pairs, indicating the cop_seq of scopes
217 # in which a var of that name is valid.
220 # COP for statement being deparsed
223 # name of the current package for deparsed code
226 # array of [cop_seq, CV, is_format?] for subs and formats we still
230 # as above, but [name, prototype] for subs that never got a GV
232 # subs_done, forms_done:
233 # keys are addresses of GVs for subs and formats we've already
234 # deparsed (or at least put into subs_todo)
237 # keys are names of subs for which we've printed declarations.
238 # That means we can omit parentheses from the arguments.
241 # Keeps track of fully qualified names of all deparsed subs.
246 # cuddle: ` ' or `\n', depending on -sC
251 # A little explanation of how precedence contexts and associativity
254 # deparse() calls each per-op subroutine with an argument $cx (short
255 # for context, but not the same as the cx* in the perl core), which is
256 # a number describing the op's parents in terms of precedence, whether
257 # they're inside an expression or at statement level, etc. (see
258 # chart below). When ops with children call deparse on them, they pass
259 # along their precedence. Fractional values are used to implement
260 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
261 # parentheses hacks. The major disadvantage of this scheme is that
262 # it doesn't know about right sides and left sides, so say if you
263 # assign a listop to a variable, it can't tell it's allowed to leave
264 # the parens off the listop.
267 # 26 [TODO] inside interpolation context ("")
268 # 25 left terms and list operators (leftward)
272 # 21 right ! ~ \ and unary + and -
277 # 16 nonassoc named unary operators
278 # 15 nonassoc < > <= >= lt gt le ge
279 # 14 nonassoc == != <=> eq ne cmp
286 # 7 right = += -= *= etc.
288 # 5 nonassoc list operators (rightward)
292 # 1 statement modifiers
293 # 0.5 statements, but still print scopes as do { ... }
296 # Nonprinting characters with special meaning:
297 # \cS - steal parens (see maybe_parens_unop)
298 # \n - newline and indent
299 # \t - increase indent
300 # \b - decrease indent (`outdent')
301 # \f - flush left (no indent)
302 # \cK - kill following semicolon, if any
306 return class($op) eq "NULL";
311 my($cv, $is_form) = @_;
312 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
314 if ($cv->OUTSIDE_SEQ) {
315 $seq = $cv->OUTSIDE_SEQ;
316 } elsif (!null($cv->START) and is_state($cv->START)) {
317 $seq = $cv->START->cop_seq;
321 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
322 unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
323 $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
329 my $ent = shift @{$self->{'subs_todo'}};
332 my $name = $self->gv_name($gv);
334 return "format $name =\n"
335 . $self->deparse_format($ent->[1]). "\n";
337 $self->{'subs_declared'}{$name} = 1;
338 if ($name eq "BEGIN") {
339 my $use_dec = $self->begin_is_use($cv);
340 if (defined ($use_dec) and $self->{'expand'} < 5) {
341 return () if 0 == length($use_dec);
346 if ($self->{'linenums'}) {
347 my $line = $gv->LINE;
348 my $file = $gv->FILE;
349 $l = "\n\f#line $line \"$file\"\n";
352 if (class($cv->STASH) ne "SPECIAL") {
353 my $stash = $cv->STASH->NAME;
354 if ($stash ne $self->{'curstash'}) {
355 $p = "package $stash;\n";
356 $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
357 $self->{'curstash'} = $stash;
359 $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
361 return "${p}${l}sub $name " . $self->deparse_sub($cv);
365 # Return a "use" declaration for this BEGIN block, if appropriate
367 my ($self, $cv) = @_;
368 my $root = $cv->ROOT;
369 local @$self{qw'curcv curcvlex'} = ($cv);
371 #B::walkoptree($cv->ROOT, "debug");
372 my $lineseq = $root->first;
373 return if $lineseq->name ne "lineseq";
375 my $req_op = $lineseq->first->sibling;
376 return if $req_op->name ne "require";
379 if ($req_op->first->private & OPpCONST_BARE) {
380 # Actually it should always be a bareword
381 $module = $self->const_sv($req_op->first)->PV;
382 $module =~ s[/][::]g;
386 $module = $self->const($self->const_sv($req_op->first), 6);
390 my $version_op = $req_op->sibling;
391 return if class($version_op) eq "NULL";
392 if ($version_op->name eq "lineseq") {
393 # We have a version parameter; skip nextstate & pushmark
394 my $constop = $version_op->first->next->next;
396 return unless $self->const_sv($constop)->PV eq $module;
397 $constop = $constop->sibling;
398 $version = $self->const_sv($constop);
399 if (class($version) eq "IV") {
400 $version = $version->int_value;
401 } elsif (class($version) eq "NV") {
402 $version = $version->NV;
403 } elsif (class($version) ne "PVMG") {
404 # Includes PVIV and PVNV
405 $version = $version->PV;
407 # version specified as a v-string
408 $version = 'v'.join '.', map ord, split //, $version->PV;
410 $constop = $constop->sibling;
411 return if $constop->name ne "method_named";
412 return if $self->const_sv($constop)->PV ne "VERSION";
415 $lineseq = $version_op->sibling;
416 return if $lineseq->name ne "lineseq";
417 my $entersub = $lineseq->first->sibling;
418 if ($entersub->name eq "stub") {
419 return "use $module $version ();\n" if defined $version;
420 return "use $module ();\n";
422 return if $entersub->name ne "entersub";
424 # See if there are import arguments
427 my $svop = $entersub->first->sibling; # Skip over pushmark
428 return unless $self->const_sv($svop)->PV eq $module;
430 # Pull out the arguments
431 for ($svop=$svop->sibling; $svop->name ne "method_named";
432 $svop = $svop->sibling) {
433 $args .= ", " if length($args);
434 $args .= $self->deparse($svop, 6);
438 my $method_named = $svop;
439 return if $method_named->name ne "method_named";
440 my $method_name = $self->const_sv($method_named)->PV;
442 if ($method_name eq "unimport") {
446 # Certain pragmas are dealt with using hint bits,
447 # so we ignore them here
448 if ($module eq 'strict' || $module eq 'integer'
449 || $module eq 'bytes' || $module eq 'warnings'
450 || $module eq 'feature') {
454 if (defined $version && length $args) {
455 return "$use $module $version ($args);\n";
456 } elsif (defined $version) {
457 return "$use $module $version;\n";
458 } elsif (length $args) {
459 return "$use $module ($args);\n";
461 return "$use $module;\n";
466 my ($self, $pack) = @_;
468 if (!defined $pack) {
473 $pack =~ s/(::)?$/::/;
477 my %stash = svref_2object($stash)->ARRAY;
478 while (my ($key, $val) = each %stash) {
479 my $class = class($val);
480 if ($class eq "PV") {
481 # Just a prototype. As an ugly but fairly effective way
482 # to find out if it belongs here is to see if the AUTOLOAD
483 # (if any) for the stash was defined in one of our files.
484 my $A = $stash{"AUTOLOAD"};
485 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
486 && class($A->CV) eq "CV") {
488 next unless $AF eq $0 || exists $self->{'files'}{$AF};
490 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
491 } elsif ($class eq "IV" && !($val->FLAGS & SVf_ROK)) {
492 # Just a name. As above.
493 # But skip proxy constant subroutines, as some form of perl-space
494 # visible code must have created them, be it a use statement, or
495 # some direct symbol-table manipulation code that we will Deparse
496 my $A = $stash{"AUTOLOAD"};
497 if (defined ($A) && class($A) eq "GV" && defined($A->CV)
498 && class($A->CV) eq "CV") {
500 next unless $AF eq $0 || exists $self->{'files'}{$AF};
502 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
503 } elsif ($class eq "GV") {
504 if (class(my $cv = $val->CV) ne "SPECIAL") {
505 next if $self->{'subs_done'}{$$val}++;
506 next if $$val != ${$cv->GV}; # Ignore imposters
509 if (class(my $cv = $val->FORM) ne "SPECIAL") {
510 next if $self->{'forms_done'}{$$val}++;
511 next if $$val != ${$cv->GV}; # Ignore imposters
514 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
515 $self->stash_subs($pack . $key)
516 unless $pack eq '' && $key eq 'main::';
517 # avoid infinite recursion
527 foreach $ar (@{$self->{'protos_todo'}}) {
528 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
529 push @ret, "sub " . $ar->[0] . "$proto;\n";
531 delete $self->{'protos_todo'};
539 while (length($opt = substr($opts, 0, 1))) {
541 $self->{'cuddle'} = " ";
542 $opts = substr($opts, 1);
543 } elsif ($opt eq "i") {
544 $opts =~ s/^i(\d+)//;
545 $self->{'indent_size'} = $1;
546 } elsif ($opt eq "T") {
547 $self->{'use_tabs'} = 1;
548 $opts = substr($opts, 1);
549 } elsif ($opt eq "v") {
550 $opts =~ s/^v([^.]*)(.|$)//;
551 $self->{'ex_const'} = $1;
558 my $self = bless {}, $class;
559 $self->{'cuddle'} = "\n";
560 $self->{'curcop'} = undef;
561 $self->{'curstash'} = "main";
562 $self->{'ex_const'} = "'???'";
563 $self->{'expand'} = 0;
564 $self->{'files'} = {};
565 $self->{'indent_size'} = 4;
566 $self->{'linenums'} = 0;
567 $self->{'parens'} = 0;
568 $self->{'subs_todo'} = [];
569 $self->{'unquote'} = 0;
570 $self->{'use_dumper'} = 0;
571 $self->{'use_tabs'} = 0;
573 $self->{'ambient_arybase'} = 0;
574 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
575 $self->{'ambient_hints'} = 0;
576 $self->{'ambient_hinthash'} = undef;
579 while (my $arg = shift @_) {
581 $self->{'use_dumper'} = 1;
582 require Data::Dumper;
583 } elsif ($arg =~ /^-f(.*)/) {
584 $self->{'files'}{$1} = 1;
585 } elsif ($arg eq "-l") {
586 $self->{'linenums'} = 1;
587 } elsif ($arg eq "-p") {
588 $self->{'parens'} = 1;
589 } elsif ($arg eq "-P") {
590 $self->{'noproto'} = 1;
591 } elsif ($arg eq "-q") {
592 $self->{'unquote'} = 1;
593 } elsif (substr($arg, 0, 2) eq "-s") {
594 $self->style_opts(substr $arg, 2);
595 } elsif ($arg =~ /^-x(\d)$/) {
596 $self->{'expand'} = $1;
603 # Mask out the bits that L<warnings::register> uses
606 $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
613 # Initialise the contextual information, either from
614 # defaults provided with the ambient_pragmas method,
615 # or from perl's own defaults otherwise.
619 $self->{'arybase'} = $self->{'ambient_arybase'};
620 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
621 ? $self->{'ambient_warnings'} & WARN_MASK
623 $self->{'hints'} = $self->{'ambient_hints'};
624 $self->{'hints'} &= 0xFF if $] < 5.009;
625 $self->{'hinthash'} = $self->{'ambient_hinthash'};
627 # also a convenient place to clear out subs_declared
628 delete $self->{'subs_declared'};
634 my $self = B::Deparse->new(@args);
635 # First deparse command-line args
636 if (defined $^I) { # deparse -i
637 print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
639 if ($^W) { # deparse -w
640 print qq(BEGIN { \$^W = $^W; }\n);
642 if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
643 my $fs = perlstring($/) || 'undef';
644 my $bs = perlstring($O::savebackslash) || 'undef';
645 print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
647 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
648 my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
649 ? B::unitcheck_av->ARRAY
651 my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
652 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
653 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
654 for my $block (@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
655 $self->todo($block, 0);
658 local($SIG{"__DIE__"}) =
660 if ($self->{'curcop'}) {
661 my $cop = $self->{'curcop'};
662 my($line, $file) = ($cop->line, $cop->file);
663 print STDERR "While deparsing $file near line $line,\n";
666 $self->{'curcv'} = main_cv;
667 $self->{'curcvlex'} = undef;
668 print $self->print_protos;
669 @{$self->{'subs_todo'}} =
670 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
671 print $self->indent($self->deparse_root(main_root)), "\n"
672 unless null main_root;
674 while (scalar(@{$self->{'subs_todo'}})) {
675 push @text, $self->next_todo;
677 print $self->indent(join("", @text)), "\n" if @text;
679 # Print __DATA__ section, if necessary
681 my $laststash = defined $self->{'curcop'}
682 ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
683 if (defined *{$laststash."::DATA"}{IO}) {
684 print "package $laststash;\n"
685 unless $laststash eq $self->{'curstash'};
687 print readline(*{$laststash."::DATA"});
695 croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
698 return $self->indent($self->deparse_sub(svref_2object($sub)));
701 sub ambient_pragmas {
703 my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
709 if ($name eq 'strict') {
712 if ($val eq 'none') {
713 $hint_bits &= ~strict::bits(qw/refs subs vars/);
719 @names = qw/refs subs vars/;
725 @names = split' ', $val;
727 $hint_bits |= strict::bits(@names);
730 elsif ($name eq '$[') {
734 elsif ($name eq 'integer'
736 || $name eq 'utf8') {
739 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
742 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
746 elsif ($name eq 're') {
748 if ($val eq 'none') {
749 $hint_bits &= ~re::bits(qw/taint eval/);
755 @names = qw/taint eval/;
761 @names = split' ',$val;
763 $hint_bits |= re::bits(@names);
766 elsif ($name eq 'warnings') {
767 if ($val eq 'none') {
768 $warning_bits = $warnings::NONE;
777 @names = split/\s+/, $val;
780 $warning_bits = $warnings::NONE if !defined ($warning_bits);
781 $warning_bits |= warnings::bits(@names);
784 elsif ($name eq 'warning_bits') {
785 $warning_bits = $val;
788 elsif ($name eq 'hint_bits') {
792 elsif ($name eq '%^H') {
797 croak "Unknown pragma type: $name";
801 croak "The ambient_pragmas method expects an even number of args";
804 $self->{'ambient_arybase'} = $arybase;
805 $self->{'ambient_warnings'} = $warning_bits;
806 $self->{'ambient_hints'} = $hint_bits;
807 $self->{'ambient_hinthash'} = $hinthash;
810 # This method is the inner loop, so try to keep it simple
815 Carp::confess("Null op in deparse") if !defined($op)
816 || class($op) eq "NULL";
817 my $meth = "pp_" . $op->name;
818 return $self->$meth($op, $cx);
824 my @lines = split(/\n/, $txt);
829 my $cmd = substr($line, 0, 1);
830 if ($cmd eq "\t" or $cmd eq "\b") {
831 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
832 if ($self->{'use_tabs'}) {
833 $leader = "\t" x ($level / 8) . " " x ($level % 8);
835 $leader = " " x $level;
837 $line = substr($line, 1);
839 if (substr($line, 0, 1) eq "\f") {
840 $line = substr($line, 1); # no indent
842 $line = $leader . $line;
846 return join("\n", @lines);
853 Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
854 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
855 local $self->{'curcop'} = $self->{'curcop'};
856 if ($cv->FLAGS & SVf_POK) {
857 $proto = "(". $cv->PV . ") ";
859 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
861 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
862 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
863 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
866 local($self->{'curcv'}) = $cv;
867 local($self->{'curcvlex'});
868 local(@$self{qw'curstash warnings hints hinthash'})
869 = @$self{qw'curstash warnings hints hinthash'};
871 if (not null $cv->ROOT) {
872 my $lineseq = $cv->ROOT->first;
873 if ($lineseq->name eq "lineseq") {
875 for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
878 $body = $self->lineseq(undef, @ops).";";
879 my $scope_en = $self->find_scope_en($lineseq);
880 if (defined $scope_en) {
881 my $subs = join"", $self->seq_subs($scope_en);
882 $body .= ";\n$subs" if length($subs);
886 $body = $self->deparse($cv->ROOT->first, 0);
890 my $sv = $cv->const_sv;
892 # uh-oh. inlinable sub... format it differently
893 return $proto . "{ " . $self->const($sv, 0) . " }\n";
894 } else { # XSUB? (or just a declaration)
898 return $proto ."{\n\t$body\n\b}" ."\n";
905 local($self->{'curcv'}) = $form;
906 local($self->{'curcvlex'});
907 local($self->{'in_format'}) = 1;
908 local(@$self{qw'curstash warnings hints hinthash'})
909 = @$self{qw'curstash warnings hints hinthash'};
910 my $op = $form->ROOT;
912 return "\f." if $op->first->name eq 'stub'
913 || $op->first->name eq 'nextstate';
914 $op = $op->first->first; # skip leavewrite, lineseq
915 while (not null $op) {
916 $op = $op->sibling; # skip nextstate
918 $kid = $op->first->sibling; # skip pushmark
919 push @text, "\f".$self->const_sv($kid)->PV;
920 $kid = $kid->sibling;
921 for (; not null $kid; $kid = $kid->sibling) {
922 push @exprs, $self->deparse($kid, 0);
924 push @text, "\f".join(", ", @exprs)."\n" if @exprs;
927 return join("", @text) . "\f.";
932 return $op->name eq "leave" || $op->name eq "scope"
933 || $op->name eq "lineseq"
934 || ($op->name eq "null" && class($op) eq "UNOP"
935 && (is_scope($op->first) || $op->first->name eq "enter"));
939 my $name = $_[0]->name;
940 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
943 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
945 return (!null($op) and null($op->sibling)
946 and $op->name eq "null" and class($op) eq "UNOP"
947 and (($op->first->name =~ /^(and|or)$/
948 and $op->first->first->sibling->name eq "lineseq")
949 or ($op->first->name eq "lineseq"
950 and not null $op->first->first->sibling
951 and $op->first->first->sibling->name eq "unstack")
955 # Check if the op and its sibling are the initialization and the rest of a
956 # for (..;..;..) { ... } loop
959 # This OP might be almost anything, though it won't be a
960 # nextstate. (It's the initialization, so in the canonical case it
961 # will be an sassign.) The sibling is (old style) a lineseq whose
962 # first child is a nextstate and whose second is a leaveloop, or
963 # (new style) an unstack whose sibling is a leaveloop.
964 my $lseq = $op->sibling;
965 return 0 unless !is_state($op) and !null($lseq);
966 if ($lseq->name eq "lineseq") {
967 if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
968 && (my $sib = $lseq->first->sibling)) {
969 return (!null($sib) && $sib->name eq "leaveloop");
971 } elsif ($lseq->name eq "unstack" && ($lseq->flags & OPf_SPECIAL)) {
972 my $sib = $lseq->sibling;
973 return $sib && !null($sib) && $sib->name eq "leaveloop";
980 return ($op->name eq "rv2sv" or
981 $op->name eq "padsv" or
982 $op->name eq "gv" or # only in array/hash constructs
983 $op->flags & OPf_KIDS && !null($op->first)
984 && $op->first->name eq "gvsv");
989 my($text, $cx, $prec) = @_;
990 if ($prec < $cx # unary ops nest just fine
991 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
992 or $self->{'parens'})
995 # In a unop, let parent reuse our parens; see maybe_parens_unop
996 $text = "\cS" . $text if $cx == 16;
1003 # same as above, but get around the `if it looks like a function' rule
1004 sub maybe_parens_unop {
1006 my($name, $kid, $cx) = @_;
1007 if ($cx > 16 or $self->{'parens'}) {
1008 $kid = $self->deparse($kid, 1);
1009 if ($name eq "umask" && $kid =~ /^\d+$/) {
1010 $kid = sprintf("%#o", $kid);
1012 return "$name($kid)";
1014 $kid = $self->deparse($kid, 16);
1015 if ($name eq "umask" && $kid =~ /^\d+$/) {
1016 $kid = sprintf("%#o", $kid);
1018 if (substr($kid, 0, 1) eq "\cS") {
1020 return $name . substr($kid, 1);
1021 } elsif (substr($kid, 0, 1) eq "(") {
1022 # avoid looks-like-a-function trap with extra parens
1023 # (`+' can lead to ambiguities)
1024 return "$name(" . $kid . ")";
1026 return "$name $kid";
1031 sub maybe_parens_func {
1033 my($func, $text, $cx, $prec) = @_;
1034 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
1035 return "$func($text)";
1037 return "$func $text";
1043 my($op, $cx, $text) = @_;
1044 my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
1045 if ($op->private & (OPpLVAL_INTRO|$our_intro)
1046 and not $self->{'avoid_local'}{$$op}) {
1047 my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
1048 if( $our_local eq 'our' ) {
1049 if ( $text !~ /^\W(\w+::)*\w+\z/
1050 and !utf8::decode($text) || $text !~ /^\W(\w+::)*\w+\z/
1052 die "Unexpected our($text)\n";
1054 $text =~ s/(\w+::)+//;
1056 if (want_scalar($op)) {
1057 return "$our_local $text";
1059 return $self->maybe_parens_func("$our_local", $text, $cx, 16);
1068 my($op, $cx, $func, @args) = @_;
1069 if ($op->private & OPpTARGET_MY) {
1070 my $var = $self->padname($op->targ);
1071 my $val = $func->($self, $op, 7, @args);
1072 return $self->maybe_parens("$var = $val", $cx, 7);
1074 return $func->($self, $op, $cx, @args);
1081 return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
1086 my($op, $cx, $text) = @_;
1087 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
1088 my $my = $op->private & OPpPAD_STATE ? "state" : "my";
1089 if (want_scalar($op)) {
1092 return $self->maybe_parens_func($my, $text, $cx, 16);
1099 # The following OPs don't have functions:
1101 # pp_padany -- does not exist after parsing
1104 if ($AUTOLOAD =~ s/^.*::pp_//) {
1105 warn "unexpected OP_".uc $AUTOLOAD;
1108 die "Undefined subroutine $AUTOLOAD called";
1112 sub DESTROY {} # Do not AUTOLOAD
1114 # $root should be the op which represents the root of whatever
1115 # we're sequencing here. If it's undefined, then we don't append
1116 # any subroutine declarations to the deparsed ops, otherwise we
1117 # append appropriate declarations.
1119 my($self, $root, @ops) = @_;
1122 my $out_cop = $self->{'curcop'};
1123 my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
1125 if (defined $root) {
1126 $limit_seq = $out_seq;
1128 $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
1129 $limit_seq = $nseq if !defined($limit_seq)
1130 or defined($nseq) && $nseq < $limit_seq;
1132 $limit_seq = $self->{'limit_seq'}
1133 if defined($self->{'limit_seq'})
1134 && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
1135 local $self->{'limit_seq'} = $limit_seq;
1137 $self->walk_lineseq($root, \@ops,
1138 sub { push @exprs, $_[0]} );
1140 my $body = join(";\n", grep {length} @exprs);
1142 if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
1143 $subs = join "\n", $self->seq_subs($limit_seq);
1145 return join(";\n", grep {length} $body, $subs);
1149 my($real_block, $self, $op, $cx) = @_;
1153 local(@$self{qw'curstash warnings hints hinthash'})
1154 = @$self{qw'curstash warnings hints hinthash'} if $real_block;
1156 $kid = $op->first->sibling; # skip enter
1157 if (is_miniwhile($kid)) {
1158 my $top = $kid->first;
1159 my $name = $top->name;
1160 if ($name eq "and") {
1162 } elsif ($name eq "or") {
1164 } else { # no conditional -> while 1 or until 0
1165 return $self->deparse($top->first, 1) . " while 1";
1167 my $cond = $top->first;
1168 my $body = $cond->sibling->first; # skip lineseq
1169 $cond = $self->deparse($cond, 1);
1170 $body = $self->deparse($body, 1);
1171 return "$body $name $cond";
1176 for (; !null($kid); $kid = $kid->sibling) {
1179 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
1180 return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
1182 my $lineseq = $self->lineseq($op, @kids);
1183 return (length ($lineseq) ? "$lineseq;" : "");
1187 sub pp_scope { scopeop(0, @_); }
1188 sub pp_lineseq { scopeop(0, @_); }
1189 sub pp_leave { scopeop(1, @_); }
1191 # This is a special case of scopeop and lineseq, for the case of the
1192 # main_root. The difference is that we print the output statements as
1193 # soon as we get them, for the sake of impatient users.
1197 local(@$self{qw'curstash warnings hints hinthash'})
1198 = @$self{qw'curstash warnings hints hinthash'};
1200 return if null $op->first; # Can happen, e.g., for Bytecode without -k
1201 for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
1204 $self->walk_lineseq($op, \@kids,
1205 sub { print $self->indent($_[0].';');
1206 print "\n" unless $_[1] == $#kids;
1211 my ($self, $op, $kids, $callback) = @_;
1213 for (my $i = 0; $i < @kids; $i++) {
1215 if (is_state $kids[$i]) {
1216 $expr = $self->deparse($kids[$i++], 0);
1218 $callback->($expr, $i);
1222 if (is_for_loop($kids[$i])) {
1223 $callback->($expr . $self->for_loop($kids[$i], 0),
1224 $i += $kids[$i]->sibling->name eq "unstack" ? 2 : 1);
1227 $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
1228 $expr =~ s/;\n?\z//;
1229 $callback->($expr, $i);
1233 # The BEGIN {} is used here because otherwise this code isn't executed
1234 # when you run B::Deparse on itself.
1236 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1237 "ENV", "ARGV", "ARGVOUT", "_"); }
1242 Carp::confess() unless ref($gv) eq "B::GV";
1243 my $stash = $gv->STASH->NAME;
1244 my $name = $gv->SAFENAME;
1245 if ($stash eq 'main' && $name =~ /^::/) {
1248 elsif (($stash eq 'main' && $globalnames{$name})
1249 or ($stash eq $self->{'curstash'} && !$globalnames{$name}
1250 && ($stash eq 'main' || $name !~ /::/))
1251 or $name =~ /^[^A-Za-z_:]/)
1255 $stash = $stash . "::";
1257 if ($name =~ /^(\^..|{)/) {
1258 $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
1260 return $stash . $name;
1263 # Return the name to use for a stash variable.
1264 # If a lexical with the same name is in scope, it may need to be
1266 sub stash_variable {
1267 my ($self, $prefix, $name) = @_;
1269 return "$prefix$name" if $name =~ /::/;
1271 unless ($prefix eq '$' || $prefix eq '@' || #'
1272 $prefix eq '%' || $prefix eq '$#') {
1273 return "$prefix$name";
1276 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1277 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
1278 return "$prefix$name";
1282 my ($self, $name) = @_;
1283 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1285 return 0 if !defined($self->{'curcop'});
1286 my $seq = $self->{'curcop'}->cop_seq;
1287 return 0 if !exists $self->{'curcvlex'}{$name};
1288 for my $a (@{$self->{'curcvlex'}{$name}}) {
1289 my ($st, $en) = @$a;
1290 return 1 if $seq > $st && $seq <= $en;
1295 sub populate_curcvlex {
1297 for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
1298 my $padlist = $cv->PADLIST;
1299 # an undef CV still in lexical chain
1300 next if class($padlist) eq "SPECIAL";
1301 my @padlist = $padlist->ARRAY;
1302 my @ns = $padlist[0]->ARRAY;
1304 for (my $i=0; $i<@ns; ++$i) {
1305 next if class($ns[$i]) eq "SPECIAL";
1306 next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
1307 if (class($ns[$i]) eq "PV") {
1308 # Probably that pesky lexical @_
1311 my $name = $ns[$i]->PVX;
1312 my ($seq_st, $seq_en) =
1313 ($ns[$i]->FLAGS & SVf_FAKE)
1315 : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
1317 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1322 sub find_scope_st { ((find_scope(@_))[0]); }
1323 sub find_scope_en { ((find_scope(@_))[1]); }
1325 # Recurses down the tree, looking for pad variable introductions and COPs
1327 my ($self, $op, $scope_st, $scope_en) = @_;
1328 carp("Undefined op in find_scope") if !defined $op;
1329 return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
1332 while(my $op = shift @queue ) {
1333 for (my $o=$op->first; $$o; $o=$o->sibling) {
1334 if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
1335 my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
1336 my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
1337 $scope_st = $s if !defined($scope_st) || $s < $scope_st;
1338 $scope_en = $e if !defined($scope_en) || $e > $scope_en;
1339 return ($scope_st, $scope_en);
1341 elsif (is_state($o)) {
1342 my $c = $o->cop_seq;
1343 $scope_st = $c if !defined($scope_st) || $c < $scope_st;
1344 $scope_en = $c if !defined($scope_en) || $c > $scope_en;
1345 return ($scope_st, $scope_en);
1347 elsif ($o->flags & OPf_KIDS) {
1348 unshift (@queue, $o);
1353 return ($scope_st, $scope_en);
1356 # Returns a list of subs which should be inserted before the COP
1358 my ($self, $op, $out_seq) = @_;
1359 my $seq = $op->cop_seq;
1360 # If we have nephews, then our sequence number indicates
1361 # the cop_seq of the end of some sort of scope.
1362 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1363 and my $nseq = $self->find_scope_st($op->sibling) ) {
1366 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1367 return $self->seq_subs($seq);
1371 my ($self, $seq) = @_;
1373 #push @text, "# ($seq)\n";
1375 return "" if !defined $seq;
1376 while (scalar(@{$self->{'subs_todo'}})
1377 and $seq > $self->{'subs_todo'}[0][0]) {
1378 push @text, $self->next_todo;
1383 # Notice how subs and formats are inserted between statements here;
1384 # also $[ assignments and pragmas.
1388 $self->{'curcop'} = $op;
1390 push @text, $self->cop_subs($op);
1391 my $stash = $op->stashpv;
1392 if ($stash ne $self->{'curstash'}) {
1393 push @text, "package $stash;\n";
1394 $self->{'curstash'} = $stash;
1397 if ($self->{'arybase'} != $op->arybase) {
1398 push @text, '$[ = '. $op->arybase .";\n";
1399 $self->{'arybase'} = $op->arybase;
1402 my $warnings = $op->warnings;
1404 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1405 $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
1407 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1408 $warning_bits = $warnings::NONE;
1410 elsif ($warnings->isa("B::SPECIAL")) {
1411 $warning_bits = undef;
1414 $warning_bits = $warnings->PV & WARN_MASK;
1417 if (defined ($warning_bits) and
1418 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1419 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1420 $self->{'warnings'} = $warning_bits;
1423 if ($self->{'hints'} != $op->hints) {
1424 push @text, declare_hints($self->{'hints'}, $op->hints);
1425 $self->{'hints'} = $op->hints;
1428 # hack to check that the hint hash hasn't changed
1430 "@{[sort %{$self->{'hinthash'} || {}}]}"
1431 ne "@{[sort %{$op->hints_hash->HASH || {}}]}") {
1432 push @text, declare_hinthash($self->{'hinthash'}, $op->hints_hash->HASH, $self->{indent_size});
1433 $self->{'hinthash'} = $op->hints_hash->HASH;
1436 # This should go after of any branches that add statements, to
1437 # increase the chances that it refers to the same line it did in
1438 # the original program.
1439 if ($self->{'linenums'}) {
1440 push @text, "\f#line " . $op->line .
1441 ' "' . $op->file, qq'"\n';
1444 push @text, $op->label . ": " if $op->label;
1446 return join("", @text);
1449 sub declare_warnings {
1450 my ($from, $to) = @_;
1451 if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
1452 return "use warnings;\n";
1454 elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
1455 return "no warnings;\n";
1457 return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
1461 my ($from, $to) = @_;
1462 my $use = $to & ~$from;
1463 my $no = $from & ~$to;
1465 for my $pragma (hint_pragmas($use)) {
1466 $decls .= "use $pragma;\n";
1468 for my $pragma (hint_pragmas($no)) {
1469 $decls .= "no $pragma;\n";
1474 # Internal implementation hints that the core sets automatically, so don't need
1475 # (or want) to be passed back to the user
1476 my %ignored_hints = (
1482 sub declare_hinthash {
1483 my ($from, $to, $indent) = @_;
1485 for my $key (keys %$to) {
1486 next if $ignored_hints{$key};
1487 if (!defined $from->{$key} or $from->{$key} ne $to->{$key}) {
1488 push @decls, qq(\$^H{'$key'} = q($to->{$key}););
1491 for my $key (keys %$from) {
1492 next if $ignored_hints{$key};
1493 if (!exists $to->{$key}) {
1494 push @decls, qq(delete \$^H{'$key'};);
1497 @decls or return '';
1498 return join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n";
1504 push @pragmas, "integer" if $bits & 0x1;
1505 push @pragmas, "strict 'refs'" if $bits & 0x2;
1506 push @pragmas, "bytes" if $bits & 0x8;
1510 sub pp_dbstate { pp_nextstate(@_) }
1511 sub pp_setstate { pp_nextstate(@_) }
1513 sub pp_unstack { return "" } # see also leaveloop
1517 my($op, $cx, $name) = @_;
1523 my($op, $cx, $name) = @_;
1531 sub pp_wantarray { baseop(@_, "wantarray") }
1532 sub pp_fork { baseop(@_, "fork") }
1533 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1534 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1535 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1536 sub pp_tms { baseop(@_, "times") }
1537 sub pp_ghostent { baseop(@_, "gethostent") }
1538 sub pp_gnetent { baseop(@_, "getnetent") }
1539 sub pp_gprotoent { baseop(@_, "getprotoent") }
1540 sub pp_gservent { baseop(@_, "getservent") }
1541 sub pp_ehostent { baseop(@_, "endhostent") }
1542 sub pp_enetent { baseop(@_, "endnetent") }
1543 sub pp_eprotoent { baseop(@_, "endprotoent") }
1544 sub pp_eservent { baseop(@_, "endservent") }
1545 sub pp_gpwent { baseop(@_, "getpwent") }
1546 sub pp_spwent { baseop(@_, "setpwent") }
1547 sub pp_epwent { baseop(@_, "endpwent") }
1548 sub pp_ggrent { baseop(@_, "getgrent") }
1549 sub pp_sgrent { baseop(@_, "setgrent") }
1550 sub pp_egrent { baseop(@_, "endgrent") }
1551 sub pp_getlogin { baseop(@_, "getlogin") }
1553 sub POSTFIX () { 1 }
1555 # I couldn't think of a good short name, but this is the category of
1556 # symbolic unary operators with interesting precedence
1560 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1561 my $kid = $op->first;
1562 $kid = $self->deparse($kid, $prec);
1563 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1567 sub pp_preinc { pfixop(@_, "++", 23) }
1568 sub pp_predec { pfixop(@_, "--", 23) }
1569 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1570 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1571 sub pp_i_preinc { pfixop(@_, "++", 23) }
1572 sub pp_i_predec { pfixop(@_, "--", 23) }
1573 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1574 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1575 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1577 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1581 if ($op->first->name =~ /^(i_)?negate$/) {
1583 $self->pfixop($op, $cx, "-", 21.5);
1585 $self->pfixop($op, $cx, "-", 21);
1588 sub pp_i_negate { pp_negate(@_) }
1594 $self->pfixop($op, $cx, "not ", 4);
1596 $self->pfixop($op, $cx, "!", 21);
1602 my($op, $cx, $name) = @_;
1604 if ($op->flags & OPf_KIDS) {
1607 # this deals with 'boolkeys' right now
1608 return $self->deparse($kid,$cx);
1610 my $builtinname = $name;
1611 $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
1612 if (defined prototype($builtinname)
1613 && prototype($builtinname) =~ /^;?\*/
1614 && $kid->name eq "rv2gv") {
1618 return $self->maybe_parens_unop($name, $kid, $cx);
1620 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1624 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1625 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1626 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1627 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1628 sub pp_defined { unop(@_, "defined") }
1629 sub pp_undef { unop(@_, "undef") }
1630 sub pp_study { unop(@_, "study") }
1631 sub pp_ref { unop(@_, "ref") }
1632 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1634 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1635 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1636 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1637 sub pp_srand { unop(@_, "srand") }
1638 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1639 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1640 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1641 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1642 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1643 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1644 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1646 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1647 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1648 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1650 sub pp_each { unop(@_, "each") }
1651 sub pp_values { unop(@_, "values") }
1652 sub pp_keys { unop(@_, "keys") }
1654 # no name because its an optimisation op that has no keyword
1657 sub pp_aeach { unop(@_, "each") }
1658 sub pp_avalues { unop(@_, "values") }
1659 sub pp_akeys { unop(@_, "keys") }
1660 sub pp_pop { unop(@_, "pop") }
1661 sub pp_shift { unop(@_, "shift") }
1663 sub pp_caller { unop(@_, "caller") }
1664 sub pp_reset { unop(@_, "reset") }
1665 sub pp_exit { unop(@_, "exit") }
1666 sub pp_prototype { unop(@_, "prototype") }
1668 sub pp_close { unop(@_, "close") }
1669 sub pp_fileno { unop(@_, "fileno") }
1670 sub pp_umask { unop(@_, "umask") }
1671 sub pp_untie { unop(@_, "untie") }
1672 sub pp_tied { unop(@_, "tied") }
1673 sub pp_dbmclose { unop(@_, "dbmclose") }
1674 sub pp_getc { unop(@_, "getc") }
1675 sub pp_eof { unop(@_, "eof") }
1676 sub pp_tell { unop(@_, "tell") }
1677 sub pp_getsockname { unop(@_, "getsockname") }
1678 sub pp_getpeername { unop(@_, "getpeername") }
1680 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1681 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1682 sub pp_readlink { unop(@_, "readlink") }
1683 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1684 sub pp_readdir { unop(@_, "readdir") }
1685 sub pp_telldir { unop(@_, "telldir") }
1686 sub pp_rewinddir { unop(@_, "rewinddir") }
1687 sub pp_closedir { unop(@_, "closedir") }
1688 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1689 sub pp_localtime { unop(@_, "localtime") }
1690 sub pp_gmtime { unop(@_, "gmtime") }
1691 sub pp_alarm { unop(@_, "alarm") }
1692 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1694 sub pp_dofile { unop(@_, "do") }
1695 sub pp_entereval { unop(@_, "eval") }
1697 sub pp_ghbyname { unop(@_, "gethostbyname") }
1698 sub pp_gnbyname { unop(@_, "getnetbyname") }
1699 sub pp_gpbyname { unop(@_, "getprotobyname") }
1700 sub pp_shostent { unop(@_, "sethostent") }
1701 sub pp_snetent { unop(@_, "setnetent") }
1702 sub pp_sprotoent { unop(@_, "setprotoent") }
1703 sub pp_sservent { unop(@_, "setservent") }
1704 sub pp_gpwnam { unop(@_, "getpwnam") }
1705 sub pp_gpwuid { unop(@_, "getpwuid") }
1706 sub pp_ggrnam { unop(@_, "getgrnam") }
1707 sub pp_ggrgid { unop(@_, "getgrgid") }
1709 sub pp_lock { unop(@_, "lock") }
1711 sub pp_continue { unop(@_, "continue"); }
1713 my ($self, $op) = @_;
1714 return "" if $op->flags & OPf_SPECIAL;
1720 my($op, $cx, $givwhen) = @_;
1722 my $enterop = $op->first;
1724 if ($enterop->flags & OPf_SPECIAL) {
1726 $block = $self->deparse($enterop->first, 0);
1729 my $cond = $enterop->first;
1730 my $cond_str = $self->deparse($cond, 1);
1731 $head = "$givwhen ($cond_str)";
1732 $block = $self->deparse($cond->sibling, 0);
1740 sub pp_leavegiven { givwhen(@_, "given"); }
1741 sub pp_leavewhen { givwhen(@_, "when"); }
1747 if ($op->private & OPpEXISTS_SUB) {
1748 # Checking for the existence of a subroutine
1749 return $self->maybe_parens_func("exists",
1750 $self->pp_rv2cv($op->first, 16), $cx, 16);
1752 if ($op->flags & OPf_SPECIAL) {
1753 # Array element, not hash element
1754 return $self->maybe_parens_func("exists",
1755 $self->pp_aelem($op->first, 16), $cx, 16);
1757 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1765 if ($op->private & OPpSLICE) {
1766 if ($op->flags & OPf_SPECIAL) {
1767 # Deleting from an array, not a hash
1768 return $self->maybe_parens_func("delete",
1769 $self->pp_aslice($op->first, 16),
1772 return $self->maybe_parens_func("delete",
1773 $self->pp_hslice($op->first, 16),
1776 if ($op->flags & OPf_SPECIAL) {
1777 # Deleting from an array, not a hash
1778 return $self->maybe_parens_func("delete",
1779 $self->pp_aelem($op->first, 16),
1782 return $self->maybe_parens_func("delete",
1783 $self->pp_helem($op->first, 16),
1791 my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
1792 if (class($op) eq "UNOP" and $op->first->name eq "const"
1793 and $op->first->private & OPpCONST_BARE)
1795 my $name = $self->const_sv($op->first)->PV;
1798 return "$opname $name";
1800 $self->unop($op, $cx, $op->first->private & OPpCONST_NOVER ? "no" : $opname);
1807 my $kid = $op->first;
1808 if (not null $kid->sibling) {
1809 # XXX Was a here-doc
1810 return $self->dquote($op);
1812 $self->unop(@_, "scalar");
1819 return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
1822 sub anon_hash_or_list {
1826 my($pre, $post) = @{{"anonlist" => ["[","]"],
1827 "anonhash" => ["{","}"]}->{$op->name}};
1829 $op = $op->first->sibling; # skip pushmark
1830 for (; !null($op); $op = $op->sibling) {
1831 $expr = $self->deparse($op, 6);
1834 if ($pre eq "{" and $cx < 1) {
1835 # Disambiguate that it's not a block
1838 return $pre . join(", ", @exprs) . $post;
1844 if ($op->flags & OPf_SPECIAL) {
1845 return $self->anon_hash_or_list($op, $cx);
1847 warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
1851 *pp_anonhash = \&pp_anonlist;
1856 my $kid = $op->first;
1857 if ($kid->name eq "null") {
1859 if (!null($kid->sibling) and
1860 $kid->sibling->name eq "anoncode") {
1861 return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) });
1862 } elsif ($kid->name eq "pushmark") {
1863 my $sib_name = $kid->sibling->name;
1864 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1865 and not $kid->sibling->flags & OPf_REF)
1867 # The @a in \(@a) isn't in ref context, but only when the
1869 return "\\(" . $self->pp_list($op->first) . ")";
1870 } elsif ($sib_name eq 'entersub') {
1871 my $text = $self->deparse($kid->sibling, 1);
1872 # Always show parens for \(&func()), but only with -p otherwise
1873 $text = "($text)" if $self->{'parens'}
1874 or $kid->sibling->private & OPpENTERSUB_AMPER;
1879 $self->pfixop($op, $cx, "\\", 20);
1883 my ($self, $info) = @_;
1884 my $text = $self->deparse_sub($info->{code});
1885 return "sub " . $text;
1888 sub pp_srefgen { pp_refgen(@_) }
1893 my $kid = $op->first;
1894 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1895 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1896 return $self->unop($op, $cx, "readline");
1902 return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
1905 # Unary operators that can occur as pseudo-listops inside double quotes
1908 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1910 if ($op->flags & OPf_KIDS) {
1912 # If there's more than one kid, the first is an ex-pushmark.
1913 $kid = $kid->sibling if not null $kid->sibling;
1914 return $self->maybe_parens_unop($name, $kid, $cx);
1916 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1920 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1921 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1922 sub pp_uc { dq_unop(@_, "uc") }
1923 sub pp_lc { dq_unop(@_, "lc") }
1924 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1928 my ($op, $cx, $name) = @_;
1929 if (class($op) eq "PVOP") {
1930 return "$name " . $op->pv;
1931 } elsif (class($op) eq "OP") {
1933 } elsif (class($op) eq "UNOP") {
1934 # Note -- loop exits are actually exempt from the
1935 # looks-like-a-func rule, but a few extra parens won't hurt
1936 return $self->maybe_parens_unop($name, $op->first, $cx);
1940 sub pp_last { loopex(@_, "last") }
1941 sub pp_next { loopex(@_, "next") }
1942 sub pp_redo { loopex(@_, "redo") }
1943 sub pp_goto { loopex(@_, "goto") }
1944 sub pp_dump { loopex(@_, "dump") }
1948 my($op, $cx, $name) = @_;
1949 if (class($op) eq "UNOP") {
1950 # Genuine `-X' filetests are exempt from the LLAFR, but not
1951 # l?stat(); for the sake of clarity, give'em all parens
1952 return $self->maybe_parens_unop($name, $op->first, $cx);
1953 } elsif (class($op) =~ /^(SV|PAD)OP$/) {
1954 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1955 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1960 sub pp_lstat { ftst(@_, "lstat") }
1961 sub pp_stat { ftst(@_, "stat") }
1962 sub pp_ftrread { ftst(@_, "-R") }
1963 sub pp_ftrwrite { ftst(@_, "-W") }
1964 sub pp_ftrexec { ftst(@_, "-X") }
1965 sub pp_fteread { ftst(@_, "-r") }
1966 sub pp_ftewrite { ftst(@_, "-w") }
1967 sub pp_fteexec { ftst(@_, "-x") }
1968 sub pp_ftis { ftst(@_, "-e") }
1969 sub pp_fteowned { ftst(@_, "-O") }
1970 sub pp_ftrowned { ftst(@_, "-o") }
1971 sub pp_ftzero { ftst(@_, "-z") }
1972 sub pp_ftsize { ftst(@_, "-s") }
1973 sub pp_ftmtime { ftst(@_, "-M") }
1974 sub pp_ftatime { ftst(@_, "-A") }
1975 sub pp_ftctime { ftst(@_, "-C") }
1976 sub pp_ftsock { ftst(@_, "-S") }
1977 sub pp_ftchr { ftst(@_, "-c") }
1978 sub pp_ftblk { ftst(@_, "-b") }
1979 sub pp_ftfile { ftst(@_, "-f") }
1980 sub pp_ftdir { ftst(@_, "-d") }
1981 sub pp_ftpipe { ftst(@_, "-p") }
1982 sub pp_ftlink { ftst(@_, "-l") }
1983 sub pp_ftsuid { ftst(@_, "-u") }
1984 sub pp_ftsgid { ftst(@_, "-g") }
1985 sub pp_ftsvtx { ftst(@_, "-k") }
1986 sub pp_fttty { ftst(@_, "-t") }
1987 sub pp_fttext { ftst(@_, "-T") }
1988 sub pp_ftbinary { ftst(@_, "-B") }
1990 sub SWAP_CHILDREN () { 1 }
1991 sub ASSIGN () { 2 } # has OP= variant
1992 sub LIST_CONTEXT () { 4 } # Assignment is in list context
1998 my $name = $op->name;
1999 if ($name eq "concat" and $op->first->name eq "concat") {
2000 # avoid spurious `=' -- see comment in pp_concat
2003 if ($name eq "null" and class($op) eq "UNOP"
2004 and $op->first->name =~ /^(and|x?or)$/
2005 and null $op->first->sibling)
2007 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
2008 # with a null that's used as the common end point of the two
2009 # flows of control. For precedence purposes, ignore it.
2010 # (COND_EXPRs have these too, but we don't bother with
2011 # their associativity).
2012 return assoc_class($op->first);
2014 return $name . ($op->flags & OPf_STACKED ? "=" : "");
2017 # Left associative operators, like `+', for which
2018 # $a + $b + $c is equivalent to ($a + $b) + $c
2021 %left = ('multiply' => 19, 'i_multiply' => 19,
2022 'divide' => 19, 'i_divide' => 19,
2023 'modulo' => 19, 'i_modulo' => 19,
2025 'add' => 18, 'i_add' => 18,
2026 'subtract' => 18, 'i_subtract' => 18,
2028 'left_shift' => 17, 'right_shift' => 17,
2030 'bit_or' => 12, 'bit_xor' => 12,
2032 'or' => 2, 'xor' => 2,
2036 sub deparse_binop_left {
2038 my($op, $left, $prec) = @_;
2039 if ($left{assoc_class($op)} && $left{assoc_class($left)}
2040 and $left{assoc_class($op)} == $left{assoc_class($left)})
2042 return $self->deparse($left, $prec - .00001);
2044 return $self->deparse($left, $prec);
2048 # Right associative operators, like `=', for which
2049 # $a = $b = $c is equivalent to $a = ($b = $c)
2052 %right = ('pow' => 22,
2053 'sassign=' => 7, 'aassign=' => 7,
2054 'multiply=' => 7, 'i_multiply=' => 7,
2055 'divide=' => 7, 'i_divide=' => 7,
2056 'modulo=' => 7, 'i_modulo=' => 7,
2058 'add=' => 7, 'i_add=' => 7,
2059 'subtract=' => 7, 'i_subtract=' => 7,
2061 'left_shift=' => 7, 'right_shift=' => 7,
2063 'bit_or=' => 7, 'bit_xor=' => 7,
2069 sub deparse_binop_right {
2071 my($op, $right, $prec) = @_;
2072 if ($right{assoc_class($op)} && $right{assoc_class($right)}
2073 and $right{assoc_class($op)} == $right{assoc_class($right)})
2075 return $self->deparse($right, $prec - .00001);
2077 return $self->deparse($right, $prec);
2083 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
2084 my $left = $op->first;
2085 my $right = $op->last;
2087 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
2091 if ($flags & SWAP_CHILDREN) {
2092 ($left, $right) = ($right, $left);
2094 $left = $self->deparse_binop_left($op, $left, $prec);
2095 $left = "($left)" if $flags & LIST_CONTEXT
2096 && $left !~ /^(my|our|local|)[\@\(]/;
2097 $right = $self->deparse_binop_right($op, $right, $prec);
2098 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
2101 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2102 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2103 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
2104 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2105 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2106 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
2107 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
2108 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
2109 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
2110 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
2111 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
2113 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
2114 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
2115 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
2116 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
2117 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
2119 sub pp_eq { binop(@_, "==", 14) }
2120 sub pp_ne { binop(@_, "!=", 14) }
2121 sub pp_lt { binop(@_, "<", 15) }
2122 sub pp_gt { binop(@_, ">", 15) }
2123 sub pp_ge { binop(@_, ">=", 15) }
2124 sub pp_le { binop(@_, "<=", 15) }
2125 sub pp_ncmp { binop(@_, "<=>", 14) }
2126 sub pp_i_eq { binop(@_, "==", 14) }
2127 sub pp_i_ne { binop(@_, "!=", 14) }
2128 sub pp_i_lt { binop(@_, "<", 15) }
2129 sub pp_i_gt { binop(@_, ">", 15) }
2130 sub pp_i_ge { binop(@_, ">=", 15) }
2131 sub pp_i_le { binop(@_, "<=", 15) }
2132 sub pp_i_ncmp { binop(@_, "<=>", 14) }
2134 sub pp_seq { binop(@_, "eq", 14) }
2135 sub pp_sne { binop(@_, "ne", 14) }
2136 sub pp_slt { binop(@_, "lt", 15) }
2137 sub pp_sgt { binop(@_, "gt", 15) }
2138 sub pp_sge { binop(@_, "ge", 15) }
2139 sub pp_sle { binop(@_, "le", 15) }
2140 sub pp_scmp { binop(@_, "cmp", 14) }
2142 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
2143 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
2146 my ($self, $op, $cx) = @_;
2147 if ($op->flags & OPf_SPECIAL) {
2148 return $self->deparse($op->last, $cx);
2151 binop(@_, "~~", 14);
2155 # `.' is special because concats-of-concats are optimized to save copying
2156 # by making all but the first concat stacked. The effect is as if the
2157 # programmer had written `($a . $b) .= $c', except legal.
2158 sub pp_concat { maybe_targmy(@_, \&real_concat) }
2162 my $left = $op->first;
2163 my $right = $op->last;
2166 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
2170 $left = $self->deparse_binop_left($op, $left, $prec);
2171 $right = $self->deparse_binop_right($op, $right, $prec);
2172 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
2175 # `x' is weird when the left arg is a list
2179 my $left = $op->first;
2180 my $right = $op->last;
2183 if ($op->flags & OPf_STACKED) {
2187 if (null($right)) { # list repeat; count is inside left-side ex-list
2188 my $kid = $left->first->sibling; # skip pushmark
2190 for (; !null($kid->sibling); $kid = $kid->sibling) {
2191 push @exprs, $self->deparse($kid, 6);
2194 $left = "(" . join(", ", @exprs). ")";
2196 $left = $self->deparse_binop_left($op, $left, $prec);
2198 $right = $self->deparse_binop_right($op, $right, $prec);
2199 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
2204 my ($op, $cx, $type) = @_;
2205 my $left = $op->first;
2206 my $right = $left->sibling;
2207 $left = $self->deparse($left, 9);
2208 $right = $self->deparse($right, 9);
2209 return $self->maybe_parens("$left $type $right", $cx, 9);
2215 my $flip = $op->first;
2216 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
2217 return $self->range($flip->first, $cx, $type);
2220 # one-line while/until is handled in pp_leave
2224 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
2225 my $left = $op->first;
2226 my $right = $op->first->sibling;
2227 if ($cx < 1 and is_scope($right) and $blockname
2228 and $self->{'expand'} < 7)
2230 $left = $self->deparse($left, 1);
2231 $right = $self->deparse($right, 0);
2232 return "$blockname ($left) {\n\t$right\n\b}\cK";
2233 } elsif ($cx < 1 and $blockname and not $self->{'parens'}
2234 and $self->{'expand'} < 7) { # $b if $a
2235 $right = $self->deparse($right, 1);
2236 $left = $self->deparse($left, 1);
2237 return "$right $blockname $left";
2238 } elsif ($cx > $lowprec and $highop) { # $a && $b
2239 $left = $self->deparse_binop_left($op, $left, $highprec);
2240 $right = $self->deparse_binop_right($op, $right, $highprec);
2241 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
2242 } else { # $a and $b
2243 $left = $self->deparse_binop_left($op, $left, $lowprec);
2244 $right = $self->deparse_binop_right($op, $right, $lowprec);
2245 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
2249 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
2250 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
2251 sub pp_dor { logop(@_, "//", 10) }
2253 # xor is syntactically a logop, but it's really a binop (contrary to
2254 # old versions of opcode.pl). Syntax is what matters here.
2255 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
2259 my ($op, $cx, $opname) = @_;
2260 my $left = $op->first;
2261 my $right = $op->first->sibling->first; # skip sassign
2262 $left = $self->deparse($left, 7);
2263 $right = $self->deparse($right, 7);
2264 return $self->maybe_parens("$left $opname $right", $cx, 7);
2267 sub pp_andassign { logassignop(@_, "&&=") }
2268 sub pp_orassign { logassignop(@_, "||=") }
2269 sub pp_dorassign { logassignop(@_, "//=") }
2273 my($op, $cx, $name) = @_;
2275 my $parens = ($cx >= 5) || $self->{'parens'};
2276 my $kid = $op->first->sibling;
2277 return $name if null $kid;
2279 $name = "socketpair" if $name eq "sockpair";
2280 my $proto = prototype("CORE::$name");
2282 && $proto =~ /^;?\*/
2283 && $kid->name eq "rv2gv") {
2284 $first = $self->deparse($kid->first, 6);
2287 $first = $self->deparse($kid, 6);
2289 if ($name eq "chmod" && $first =~ /^\d+$/) {
2290 $first = sprintf("%#o", $first);
2292 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
2293 push @exprs, $first;
2294 $kid = $kid->sibling;
2295 if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
2296 push @exprs, $self->deparse($kid->first, 6);
2297 $kid = $kid->sibling;
2299 for (; !null($kid); $kid = $kid->sibling) {
2300 push @exprs, $self->deparse($kid, 6);
2302 if ($name eq "reverse" && ($op->private & OPpREVERSE_INPLACE)) {
2303 return "$exprs[0] = $name" . ($parens ? "($exprs[0])" : " $exprs[0]");
2306 return "$name(" . join(", ", @exprs) . ")";
2308 return "$name " . join(", ", @exprs);
2312 sub pp_bless { listop(@_, "bless") }
2313 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
2314 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
2315 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
2316 sub pp_index { maybe_targmy(@_, \&listop, "index") }
2317 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
2318 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
2319 sub pp_formline { listop(@_, "formline") } # see also deparse_format
2320 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
2321 sub pp_unpack { listop(@_, "unpack") }
2322 sub pp_pack { listop(@_, "pack") }
2323 sub pp_join { maybe_targmy(@_, \&listop, "join") }
2324 sub pp_splice { listop(@_, "splice") }
2325 sub pp_push { maybe_targmy(@_, \&listop, "push") }
2326 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
2327 sub pp_reverse { listop(@_, "reverse") }
2328 sub pp_warn { listop(@_, "warn") }
2329 sub pp_die { listop(@_, "die") }
2330 # Actually, return is exempt from the LLAFR (see examples in this very
2331 # module!), but for consistency's sake, ignore that fact
2332 sub pp_return { listop(@_, "return") }
2333 sub pp_open { listop(@_, "open") }
2334 sub pp_pipe_op { listop(@_, "pipe") }
2335 sub pp_tie { listop(@_, "tie") }
2336 sub pp_binmode { listop(@_, "binmode") }
2337 sub pp_dbmopen { listop(@_, "dbmopen") }
2338 sub pp_sselect { listop(@_, "select") }
2339 sub pp_select { listop(@_, "select") }
2340 sub pp_read { listop(@_, "read") }
2341 sub pp_sysopen { listop(@_, "sysopen") }
2342 sub pp_sysseek { listop(@_, "sysseek") }
2343 sub pp_sysread { listop(@_, "sysread") }
2344 sub pp_syswrite { listop(@_, "syswrite") }
2345 sub pp_send { listop(@_, "send") }
2346 sub pp_recv { listop(@_, "recv") }
2347 sub pp_seek { listop(@_, "seek") }
2348 sub pp_fcntl { listop(@_, "fcntl") }
2349 sub pp_ioctl { listop(@_, "ioctl") }
2350 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
2351 sub pp_socket { listop(@_, "socket") }
2352 sub pp_sockpair { listop(@_, "sockpair") }
2353 sub pp_bind { listop(@_, "bind") }
2354 sub pp_connect { listop(@_, "connect") }
2355 sub pp_listen { listop(@_, "listen") }
2356 sub pp_accept { listop(@_, "accept") }
2357 sub pp_shutdown { listop(@_, "shutdown") }
2358 sub pp_gsockopt { listop(@_, "getsockopt") }
2359 sub pp_ssockopt { listop(@_, "setsockopt") }
2360 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
2361 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
2362 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
2363 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
2364 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
2365 sub pp_link { maybe_targmy(@_, \&listop, "link") }
2366 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
2367 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
2368 sub pp_open_dir { listop(@_, "opendir") }
2369 sub pp_seekdir { listop(@_, "seekdir") }
2370 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
2371 sub pp_system { maybe_targmy(@_, \&listop, "system") }
2372 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
2373 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
2374 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
2375 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
2376 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
2377 sub pp_shmget { listop(@_, "shmget") }
2378 sub pp_shmctl { listop(@_, "shmctl") }
2379 sub pp_shmread { listop(@_, "shmread") }
2380 sub pp_shmwrite { listop(@_, "shmwrite") }
2381 sub pp_msgget { listop(@_, "msgget") }
2382 sub pp_msgctl { listop(@_, "msgctl") }
2383 sub pp_msgsnd { listop(@_, "msgsnd") }
2384 sub pp_msgrcv { listop(@_, "msgrcv") }
2385 sub pp_semget { listop(@_, "semget") }
2386 sub pp_semctl { listop(@_, "semctl") }
2387 sub pp_semop { listop(@_, "semop") }
2388 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
2389 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
2390 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
2391 sub pp_gsbyname { listop(@_, "getservbyname") }
2392 sub pp_gsbyport { listop(@_, "getservbyport") }
2393 sub pp_syscall { listop(@_, "syscall") }
2398 my $text = $self->dq($op->first->sibling); # skip pushmark
2399 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
2400 or $text =~ /[<>]/) {
2401 return 'glob(' . single_delim('qq', '"', $text) . ')';
2403 return '<' . $text . '>';
2407 # Truncate is special because OPf_SPECIAL makes a bareword first arg
2408 # be a filehandle. This could probably be better fixed in the core
2409 # by moving the GV lookup into ck_truc.
2415 my $parens = ($cx >= 5) || $self->{'parens'};
2416 my $kid = $op->first->sibling;
2418 if ($op->flags & OPf_SPECIAL) {
2419 # $kid is an OP_CONST
2420 $fh = $self->const_sv($kid)->PV;
2422 $fh = $self->deparse($kid, 6);
2423 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2425 my $len = $self->deparse($kid->sibling, 6);
2427 return "truncate($fh, $len)";
2429 return "truncate $fh, $len";
2435 my($op, $cx, $name) = @_;
2437 my $kid = $op->first->sibling;
2439 if ($op->flags & OPf_STACKED) {
2441 $indir = $indir->first; # skip rv2gv
2442 if (is_scope($indir)) {
2443 $indir = "{" . $self->deparse($indir, 0) . "}";
2444 $indir = "{;}" if $indir eq "{}";
2445 } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
2446 $indir = $self->const_sv($indir)->PV;
2448 $indir = $self->deparse($indir, 24);
2450 $indir = $indir . " ";
2451 $kid = $kid->sibling;
2453 if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
2454 $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
2457 elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
2458 $indir = '{$b cmp $a} ';
2460 for (; !null($kid); $kid = $kid->sibling) {
2461 $expr = $self->deparse($kid, 6);
2465 if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
2466 $name2 = 'reverse sort';
2468 if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
2469 return "$exprs[0] = $name2 $indir $exprs[0]";
2472 my $args = $indir . join(", ", @exprs);
2473 if ($indir ne "" and $name eq "sort") {
2474 # We don't want to say "sort(f 1, 2, 3)", since perl -w will
2475 # give bareword warnings in that case. Therefore if context
2476 # requires, we'll put parens around the outside "(sort f 1, 2,
2477 # 3)". Unfortunately, we'll currently think the parens are
2478 # necessary more often that they really are, because we don't
2479 # distinguish which side of an assignment we're on.
2481 return "($name2 $args)";
2483 return "$name2 $args";
2486 return $self->maybe_parens_func($name2, $args, $cx, 5);
2491 sub pp_prtf { indirop(@_, "printf") }
2492 sub pp_print { indirop(@_, "print") }
2493 sub pp_say { indirop(@_, "say") }
2494 sub pp_sort { indirop(@_, "sort") }
2498 my($op, $cx, $name) = @_;
2500 my $kid = $op->first; # this is the (map|grep)start
2501 $kid = $kid->first->sibling; # skip a pushmark
2502 my $code = $kid->first; # skip a null
2503 if (is_scope $code) {
2504 $code = "{" . $self->deparse($code, 0) . "} ";
2506 $code = $self->deparse($code, 24) . ", ";
2508 $kid = $kid->sibling;
2509 for (; !null($kid); $kid = $kid->sibling) {
2510 $expr = $self->deparse($kid, 6);
2511 push @exprs, $expr if defined $expr;
2513 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2516 sub pp_mapwhile { mapop(@_, "map") }
2517 sub pp_grepwhile { mapop(@_, "grep") }
2518 sub pp_mapstart { baseop(@_, "map") }
2519 sub pp_grepstart { baseop(@_, "grep") }
2525 my $kid = $op->first->sibling; # skip pushmark
2527 my $local = "either"; # could be local(...), my(...), state(...) or our(...)
2528 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2529 # This assumes that no other private flags equal 128, and that
2530 # OPs that store things other than flags in their op_private,
2531 # like OP_AELEMFAST, won't be immediate children of a list.
2533 # OP_ENTERSUB can break this logic, so check for it.
2534 # I suspect that open and exit can too.
2536 if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
2537 or $lop->name eq "undef")
2538 or $lop->name eq "entersub"
2539 or $lop->name eq "exit"
2540 or $lop->name eq "open")
2542 $local = ""; # or not
2545 if ($lop->name =~ /^pad[ash]v$/) {
2546 if ($lop->private & OPpPAD_STATE) { # state()
2547 ($local = "", last) if $local =~ /^(?:local|our|my)$/;
2550 ($local = "", last) if $local =~ /^(?:local|our|state)$/;
2553 } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
2554 && $lop->private & OPpOUR_INTRO
2555 or $lop->name eq "null" && $lop->first->name eq "gvsv"
2556 && $lop->first->private & OPpOUR_INTRO) { # our()
2557 ($local = "", last) if $local =~ /^(?:my|local|state)$/;
2559 } elsif ($lop->name ne "undef"
2560 # specifically avoid the "reverse sort" optimisation,
2561 # where "reverse" is nullified
2562 && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
2565 ($local = "", last) if $local =~ /^(?:my|our|state)$/;
2569 $local = "" if $local eq "either"; # no point if it's all undefs
2570 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2571 for (; !null($kid); $kid = $kid->sibling) {
2573 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2578 $self->{'avoid_local'}{$$lop}++;
2579 $expr = $self->deparse($kid, 6);
2580 delete $self->{'avoid_local'}{$$lop};
2582 $expr = $self->deparse($kid, 6);
2587 return "$local(" . join(", ", @exprs) . ")";
2589 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2593 sub is_ifelse_cont {
2595 return ($op->name eq "null" and class($op) eq "UNOP"
2596 and $op->first->name =~ /^(and|cond_expr)$/
2597 and is_scope($op->first->first->sibling));
2603 my $cond = $op->first;
2604 my $true = $cond->sibling;
2605 my $false = $true->sibling;
2606 my $cuddle = $self->{'cuddle'};
2607 unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
2608 (is_scope($false) || is_ifelse_cont($false))
2609 and $self->{'expand'} < 7) {
2610 $cond = $self->deparse($cond, 8);
2611 $true = $self->deparse($true, 6);
2612 $false = $self->deparse($false, 8);
2613 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2616 $cond = $self->deparse($cond, 1);
2617 $true = $self->deparse($true, 0);
2618 my $head = "if ($cond) {\n\t$true\n\b}";
2620 while (!null($false) and is_ifelse_cont($false)) {
2621 my $newop = $false->first;
2622 my $newcond = $newop->first;
2623 my $newtrue = $newcond->sibling;
2624 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2625 if ($newcond->name eq "lineseq")
2627 # lineseq to ensure correct line numbers in elsif()
2628 # Bug #37302 fixed by change #33710.
2629 $newcond = $newcond->first->sibling;
2631 $newcond = $self->deparse($newcond, 1);
2632 $newtrue = $self->deparse($newtrue, 0);
2633 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2635 if (!null($false)) {
2636 $false = $cuddle . "else {\n\t" .
2637 $self->deparse($false, 0) . "\n\b}\cK";
2641 return $head . join($cuddle, "", @elsifs) . $false;
2645 my ($self, $op, $cx) = @_;
2646 my $cond = $op->first;
2647 my $true = $cond->sibling;
2649 return $self->deparse($true, $cx);
2654 my($op, $cx, $init) = @_;
2655 my $enter = $op->first;
2656 my $kid = $enter->sibling;
2657 local(@$self{qw'curstash warnings hints hinthash'})
2658 = @$self{qw'curstash warnings hints hinthash'};
2663 if ($kid->name eq "lineseq") { # bare or infinite loop
2664 if ($kid->last->name eq "unstack") { # infinite
2665 $head = "while (1) "; # Can't use for(;;) if there's a continue
2671 } elsif ($enter->name eq "enteriter") { # foreach
2672 my $ary = $enter->first->sibling; # first was pushmark
2673 my $var = $ary->sibling;
2674 if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
2675 # "reverse" was optimised away
2676 $ary = listop($self, $ary->first->sibling, 1, 'reverse');
2677 } elsif ($enter->flags & OPf_STACKED
2678 and not null $ary->first->sibling->sibling)
2680 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2681 $self->deparse($ary->first->sibling->sibling, 9);
2683 $ary = $self->deparse($ary, 1);
2686 if ($enter->flags & OPf_SPECIAL) { # thread special var
2687 $var = $self->pp_threadsv($enter, 1);
2688 } else { # regular my() variable
2689 $var = $self->pp_padsv($enter, 1);
2691 } elsif ($var->name eq "rv2gv") {
2692 $var = $self->pp_rv2sv($var, 1);
2693 if ($enter->private & OPpOUR_INTRO) {
2694 # our declarations don't have package names
2695 $var =~ s/^(.).*::/$1/;
2698 } elsif ($var->name eq "gv") {
2699 $var = "\$" . $self->deparse($var, 1);
2701 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2702 if (!is_state $body->first and $body->first->name ne "stub") {
2703 confess unless $var eq '$_';
2704 $body = $body->first;
2705 return $self->deparse($body, 2) . " foreach ($ary)";
2707 $head = "foreach $var ($ary) ";
2708 } elsif ($kid->name eq "null") { # while/until
2710 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2711 $cond = $self->deparse($kid->first, 1);
2712 $head = "$name ($cond) ";
2713 $body = $kid->first->sibling;
2714 } elsif ($kid->name eq "stub") { # bare and empty
2715 return "{;}"; # {} could be a hashref
2717 # If there isn't a continue block, then the next pointer for the loop
2718 # will point to the unstack, which is kid's last child, except
2719 # in a bare loop, when it will point to the leaveloop. When neither of
2720 # these conditions hold, then the second-to-last child is the continue
2721 # block (or the last in a bare loop).
2722 my $cont_start = $enter->nextop;
2724 if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
2726 $cont = $body->last;
2728 $cont = $body->first;
2729 while (!null($cont->sibling->sibling)) {
2730 $cont = $cont->sibling;
2733 my $state = $body->first;
2734 my $cuddle = $self->{'cuddle'};
2736 for (; $$state != $$cont; $state = $state->sibling) {
2737 push @states, $state;
2739 $body = $self->lineseq(undef, @states);
2740 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2741 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2744 $cont = $cuddle . "continue {\n\t" .
2745 $self->deparse($cont, 0) . "\n\b}\cK";
2748 return "" if !defined $body;
2750 $head = "for ($init; $cond;) ";
2753 $body = $self->deparse($body, 0);
2755 $body =~ s/;?$/;\n/;
2757 return $head . "{\n\t" . $body . "\b}" . $cont;
2760 sub pp_leaveloop { shift->loop_common(@_, "") }
2765 my $init = $self->deparse($op, 1);
2766 my $s = $op->sibling;
2767 my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
2768 return $self->loop_common($ll, $cx, $init);
2773 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2776 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2777 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2778 BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
2779 BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
2784 if (class($op) eq "OP") {
2786 return $self->{'ex_const'} if $op->targ == OP_CONST;
2787 } elsif ($op->first->name eq "pushmark") {
2788 return $self->pp_list($op, $cx);
2789 } elsif ($op->first->name eq "enter") {
2790 return $self->pp_leave($op, $cx);
2791 } elsif ($op->first->name eq "leave") {
2792 return $self->pp_leave($op->first, $cx);
2793 } elsif ($op->first->name eq "scope") {
2794 return $self->pp_scope($op->first, $cx);
2795 } elsif ($op->targ == OP_STRINGIFY) {
2796 return $self->dquote($op, $cx);
2797 } elsif (!null($op->first->sibling) and
2798 $op->first->sibling->name eq "readline" and
2799 $op->first->sibling->flags & OPf_STACKED) {
2800 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2801 . $self->deparse($op->first->sibling, 7),
2803 } elsif (!null($op->first->sibling) and
2804 $op->first->sibling->name eq "trans" and
2805 $op->first->sibling->flags & OPf_STACKED) {
2806 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2807 . $self->deparse($op->first->sibling, 20),
2809 } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
2810 return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
2811 } elsif (!null($op->first->sibling) and
2812 $op->first->sibling->name eq "null" and
2813 class($op->first->sibling) eq "UNOP" and
2814 $op->first->sibling->first->flags & OPf_STACKED and
2815 $op->first->sibling->first->name eq "rcatline") {
2816 return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
2817 . $self->deparse($op->first->sibling, 18),
2820 return $self->deparse($op->first, $cx);
2827 return $self->padname_sv($targ)->PVX;
2833 return substr($self->padname($op->targ), 1); # skip $/@/%
2839 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2842 sub pp_padav { pp_padsv(@_) }
2843 sub pp_padhv { pp_padsv(@_) }
2848 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2849 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2850 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2857 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2863 if (class($op) eq "PADOP") {
2864 return $self->padval($op->padix);
2865 } else { # class($op) eq "SVOP"
2873 my $gv = $self->gv_or_padgv($op);
2874 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2875 $self->gv_name($gv)));
2881 my $gv = $self->gv_or_padgv($op);
2882 return $self->gv_name($gv);
2889 if ($op->flags & OPf_SPECIAL) { # optimised PADAV
2890 $name = $self->padname($op->targ);
2894 my $gv = $self->gv_or_padgv($op);
2895 $name = $self->gv_name($gv);
2896 $name = $self->{'curstash'}."::$name"
2897 if $name !~ /::/ && $self->lex_in_scope('@'.$name);
2898 $name = '$' . $name;
2901 return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
2906 my($op, $cx, $type) = @_;
2908 if (class($op) eq 'NULL' || !$op->can("first")) {
2909 carp("Unexpected op in pp_rv2x");
2912 my $kid = $op->first;
2913 if ($kid->name eq "gv") {
2914 return $self->stash_variable($type, $self->deparse($kid, 0));
2915 } elsif (is_scalar $kid) {
2916 my $str = $self->deparse($kid, 0);
2917 if ($str =~ /^\$([^\w\d])\z/) {
2918 # "$$+" isn't a legal way to write the scalar dereference
2919 # of $+, since the lexer can't tell you aren't trying to
2920 # do something like "$$ + 1" to get one more than your
2921 # PID. Either "${$+}" or "$${+}" are workable
2922 # disambiguations, but if the programmer did the former,
2923 # they'd be in the "else" clause below rather than here.
2924 # It's not clear if this should somehow be unified with
2925 # the code in dq and re_dq that also adds lexer
2926 # disambiguation braces.
2927 $str = '$' . "{$1}"; #'
2929 return $type . $str;
2931 return $type . "{" . $self->deparse($kid, 0) . "}";
2935 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2936 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2937 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2943 if ($op->first->name eq "padav") {
2944 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2946 return $self->maybe_local($op, $cx,
2947 $self->rv2x($op->first, $cx, '$#'));
2951 # skip down to the old, ex-rv2cv
2953 my ($self, $op, $cx) = @_;
2954 if (!null($op->first) && $op->first->name eq 'null' &&
2955 $op->first->targ eq OP_LIST)
2957 return $self->rv2x($op->first->first->sibling, $cx, "&")
2960 return $self->rv2x($op, $cx, "")
2966 my($cx, @list) = @_;
2967 my @a = map $self->const($_, 6), @list;
2972 } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
2973 # collapse (-1,0,1,2) into (-1..2)
2974 my ($s, $e) = @a[0,-1];
2976 return $self->maybe_parens("$s..$e", $cx, 9)
2977 unless grep $i++ != $_, @a;
2979 return $self->maybe_parens(join(", ", @a), $cx, 6);
2985 my $kid = $op->first;
2986 if ($kid->name eq "const") { # constant list
2987 my $av = $self->const_sv($kid);
2988 return $self->list_const($cx, $av->ARRAY);
2990 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2994 sub is_subscriptable {
2996 if ($op->name =~ /^[ahg]elem/) {
2998 } elsif ($op->name eq "entersub") {
2999 my $kid = $op->first;
3000 return 0 unless null $kid->sibling;
3002 $kid = $kid->sibling until null $kid->sibling;
3003 return 0 if is_scope($kid);
3005 return 0 if $kid->name eq "gv";
3006 return 0 if is_scalar($kid);
3007 return is_subscriptable($kid);
3013 sub elem_or_slice_array_name
3016 my ($array, $left, $padname, $allow_arrow) = @_;
3018 if ($array->name eq $padname) {
3019 return $self->padany($array);
3020 } elsif (is_scope($array)) { # ${expr}[0]
3021 return "{" . $self->deparse($array, 0) . "}";
3022 } elsif ($array->name eq "gv") {
3023 $array = $self->gv_name($self->gv_or_padgv($array));
3024 if ($array !~ /::/) {
3025 my $prefix = ($left eq '[' ? '@' : '%');
3026 $array = $self->{curstash}.'::'.$array
3027 if $self->lex_in_scope($prefix . $array);
3030 } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
3031 return $self->deparse($array, 24);
3037 sub elem_or_slice_single_index
3042 $idx = $self->deparse($idx, 1);
3044 # Outer parens in an array index will confuse perl
3045 # if we're interpolating in a regular expression, i.e.
3046 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
3048 # If $self->{parens}, then an initial '(' will
3049 # definitely be paired with a final ')'. If
3050 # !$self->{parens}, the misleading parens won't
3051 # have been added in the first place.
3053 # [You might think that we could get "(...)...(...)"
3054 # where the initial and final parens do not match
3055 # each other. But we can't, because the above would
3056 # only happen if there's an infix binop between the
3057 # two pairs of parens, and *that* means that the whole
3058 # expression would be parenthesized as well.]
3060 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
3062 # Hash-element braces will autoquote a bareword inside themselves.
3063 # We need to make sure that C<$hash{warn()}> doesn't come out as
3064 # C<$hash{warn}>, which has a quite different meaning. Currently
3065 # B::Deparse will always quote strings, even if the string was a
3066 # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
3067 # for constant strings.) So we can cheat slightly here - if we see
3068 # a bareword, we know that it is supposed to be a function call.
3070 $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
3077 my ($op, $cx, $left, $right, $padname) = @_;
3078 my($array, $idx) = ($op->first, $op->first->sibling);
3080 $idx = $self->elem_or_slice_single_index($idx);
3082 unless ($array->name eq $padname) { # Maybe this has been fixed
3083 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
3085 if (my $array_name=$self->elem_or_slice_array_name
3086 ($array, $left, $padname, 1)) {
3087 return "\$" . $array_name . $left . $idx . $right;
3089 # $x[20][3]{hi} or expr->[20]
3090 my $arrow = is_subscriptable($array) ? "" : "->";
3091 return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
3096 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
3097 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
3102 my($glob, $part) = ($op->first, $op->last);
3103 $glob = $glob->first; # skip rv2gv
3104 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
3105 my $scope = is_scope($glob);
3106 $glob = $self->deparse($glob, 0);
3107 $part = $self->deparse($part, 1);
3108 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
3113 my ($op, $cx, $left, $right, $regname, $padname) = @_;
3115 my(@elems, $kid, $array, $list);
3116 if (class($op) eq "LISTOP") {
3118 } else { # ex-hslice inside delete()
3119 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
3123 $array = $array->first
3124 if $array->name eq $regname or $array->name eq "null";
3125 $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
3126 $kid = $op->first->sibling; # skip pushmark
3127 if ($kid->name eq "list") {
3128 $kid = $kid->first->sibling; # skip list, pushmark
3129 for (; !null $kid; $kid = $kid->sibling) {
3130 push @elems, $self->deparse($kid, 6);
3132 $list = join(", ", @elems);
3134 $list = $self->elem_or_slice_single_index($kid);
3136 return "\@" . $array . $left . $list . $right;
3139 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
3140 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
3145 my $idx = $op->first;
3146 my $list = $op->last;
3148 $list = $self->deparse($list, 1);
3149 $idx = $self->deparse($idx, 1);
3150 return "($list)" . "[$idx]";
3155 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
3160 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
3166 my $kid = $op->first->sibling; # skip pushmark
3167 my($meth, $obj, @exprs);
3168 if ($kid->name eq "list" and want_list $kid) {
3169 # When an indirect object isn't a bareword but the args are in
3170 # parens, the parens aren't part of the method syntax (the LLAFR
3171 # doesn't apply), but they make a list with OPf_PARENS set that
3172 # doesn't get flattened by the append_elem that adds the method,
3173 # making a (object, arg1, arg2, ...) list where the object
3174 # usually is. This can be distinguished from
3175 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
3176 # object) because in the later the list is in scalar context
3177 # as the left side of -> always is, while in the former
3178 # the list is in list context as method arguments always are.
3179 # (Good thing there aren't method prototypes!)
3180 $meth = $kid->sibling;
3181 $kid = $kid->first->sibling; # skip pushmark
3183 $kid = $kid->sibling;
3184 for (; not null $kid; $kid = $kid->sibling) {
3189 $kid = $kid->sibling;
3190 for (; !null ($kid->sibling) && $kid->name ne "method_named";
3191 $kid = $kid->sibling) {
3197 if ($meth->name eq "method_named") {
3198 $meth = $self->const_sv($meth)->PV;
3200 $meth = $meth->first;
3201 if ($meth->name eq "const") {
3202 # As of 5.005_58, this case is probably obsoleted by the
3203 # method_named case above
3204 $meth = $self->const_sv($meth)->PV; # needs to be bare
3208 return { method => $meth, variable_method => ref($meth),
3209 object => $obj, args => \@exprs };
3212 # compat function only
3215 my $info = $self->_method(@_);
3216 return $self->e_method( $self->_method(@_) );
3220 my ($self, $info) = @_;
3221 my $obj = $self->deparse($info->{object}, 24);
3223 my $meth = $info->{method};
3224 $meth = $self->deparse($meth, 1) if $info->{variable_method};
3225 my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
3226 my $kid = $obj . "->" . $meth;
3228 return $kid . "(" . $args . ")"; # parens mandatory
3234 # returns "&" if the prototype doesn't match the args,
3235 # or ("", $args_after_prototype_demunging) if it does.
3238 return "&" if $self->{'noproto'};
3239 my($proto, @args) = @_;
3243 # An unbackslashed @ or % gobbles up the rest of the args
3244 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
3246 $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)//;
3249 return "&" if @args;
3250 } elsif ($chr eq ";") {
3252 } elsif ($chr eq "@" or $chr eq "%") {
3253 push @reals, map($self->deparse($_, 6), @args);
3258 if ($chr eq "\$" || $chr eq "_") {
3259 if (want_scalar $arg) {
3260 push @reals, $self->deparse($arg, 6);
3264 } elsif ($chr eq "&") {
3265 if ($arg->name =~ /^(s?refgen|undef)$/) {
3266 push @reals, $self->deparse($arg, 6);
3270 } elsif ($chr eq "*") {
3271 if ($arg->name =~ /^s?refgen$/
3272 and $arg->first->first->name eq "rv2gv")
3274 $real = $arg->first->first; # skip refgen, null
3275 if ($real->first->name eq "gv") {
3276 push @reals, $self->deparse($real, 6);
3278 push @reals, $self->deparse($real->first, 6);
3283 } elsif (substr($chr, 0, 1) eq "\\") {
3285 if ($arg->name =~ /^s?refgen$/ and
3286 !null($real = $arg->first) and
3287 ($chr =~ /\$/ && is_scalar($real->first)
3289 && class($real->first->sibling) ne 'NULL'
3290 && $real->first->sibling->name
3293 && class($real->first->sibling) ne 'NULL'
3294 && $real->first->sibling->name
3296 #or ($chr =~ /&/ # This doesn't work
3297 # && $real->first->name eq "rv2cv")
3299 && $real->first->name eq "rv2gv")))
3301 push @reals, $self->deparse($real, 6);
3308 return "&" if $proto and !$doneok; # too few args and no `;'
3309 return "&" if @args; # too many args
3310 return ("", join ", ", @reals);
3316 return $self->e_method($self->_method($op, $cx))
3317 unless null $op->first->sibling;
3321 if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
3323 } elsif ($op->private & OPpENTERSUB_AMPER) {
3327 $kid = $kid->first->sibling; # skip ex-list, pushmark
3328 for (; not null $kid->sibling; $kid = $kid->sibling) {
3333 if (is_scope($kid)) {
3335 $kid = "{" . $self->deparse($kid, 0) . "}";
3336 } elsif ($kid->first->name eq "gv") {
3337 my $gv = $self->gv_or_padgv($kid->first);
3338 if (class($gv->CV) ne "SPECIAL") {
3339 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
3341 $simple = 1; # only calls of named functions can be prototyped
3342 $kid = $self->deparse($kid, 24);
3344 if ($kid eq 'main::') {
3346 } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
3347 $kid = single_delim("q", "'", $kid) . '->';
3350 } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
3352 $kid = $self->deparse($kid, 24);
3355 my $arrow = is_subscriptable($kid->first) ? "" : "->";
3356 $kid = $self->deparse($kid, 24) . $arrow;
3359 # Doesn't matter how many prototypes there are, if
3360 # they haven't happened yet!
3364 no warnings 'uninitialized';
3365 $declared = exists $self->{'subs_declared'}{$kid}
3367 defined &{ ${$self->{'curstash'}."::"}{$kid} }
3369 $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
3370 && defined prototype $self->{'curstash'}."::".$kid
3372 if (!$declared && defined($proto)) {
3373 # Avoid "too early to check prototype" warning
3374 ($amper, $proto) = ('&');
3379 if ($declared and defined $proto and not $amper) {
3380 ($amper, $args) = $self->check_proto($proto, @exprs);
3381 if ($amper eq "&") {
3382 $args = join(", ", map($self->deparse($_, 6), @exprs));
3385 $args = join(", ", map($self->deparse($_, 6), @exprs));
3387 if ($prefix or $amper) {
3388 if ($op->flags & OPf_STACKED) {
3389 return $prefix . $amper . $kid . "(" . $args . ")";
3391 return $prefix . $amper. $kid;
3394 # glob() invocations can be translated into calls of
3395 # CORE::GLOBAL::glob with a second parameter, a number.
3397 if ($kid eq "CORE::GLOBAL::glob") {
3399 $args =~ s/\s*,[^,]+$//;
3402 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
3403 # so it must have been translated from a keyword call. Translate
3405 $kid =~ s/^CORE::GLOBAL:://;
3407 my $dproto = defined($proto) ? $proto : "undefined";
3409 return "$kid(" . $args . ")";
3410 } elsif ($dproto eq "") {
3412 } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
3413 # is_scalar is an excessively conservative test here:
3414 # really, we should be comparing to the precedence of the
3415 # top operator of $exprs[0] (ala unop()), but that would
3416 # take some major code restructuring to do right.
3417 return $self->maybe_parens_func($kid, $args, $cx, 16);
3418 } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
3419 return $self->maybe_parens_func($kid, $args, $cx, 5);
3421 return "$kid(" . $args . ")";
3426 sub pp_enterwrite { unop(@_, "write") }
3428 # escape things that cause interpolation in double quotes,
3429 # but not character escapes
3432 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
3440 # Matches any string which is balanced with respect to {braces}
3451 # the same, but treat $|, $), $( and $ at the end of the string differently
3465 (\(\?\??\{$bal\}\)) # $4
3471 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3476 # This is for regular expressions with the /x modifier
3477 # We have to leave comments unmangled.
3478 sub re_uninterp_extended {
3491 ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
3492 | \#[^\n]* # (skip over comments)
3499 /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
3505 my %unctrl = # portable to to EBCDIC
3507 "\c@" => '\c@', # unused
3534 "\c[" => '\c[', # unused
3535 "\c\\" => '\c\\', # unused
3536 "\c]" => '\c]', # unused
3537 "\c_" => '\c_', # unused
3540 # character escapes, but not delimiters that might need to be escaped
3541 sub escape_str { # ASCII, UTF8
3543 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3545 # $str =~ s/\cH/\\b/g; # \b means something different in a regex
3551 $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
3552 $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
3556 # For regexes with the /x modifier.
3557 # Leave whitespace unmangled.
3558 sub escape_extended_re {
3560 $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
3561 $str =~ s/([[:^print:]])/
3562 ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
3563 $str =~ s/\n/\n\f/g;
3567 # Don't do this for regexen
3570 $str =~ s/\\/\\\\/g;
3574 # Remove backslashes which precede literal control characters,
3575 # to avoid creating ambiguity when we escape the latter.
3579 # the insane complexity here is due to the behaviour of "\c\"
3580 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
3584 sub balanced_delim {
3586 my @str = split //, $str;
3587 my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
3588 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
3589 ($open, $close) = @$ar;
3590 $fail = 0; $cnt = 0; $last_bs = 0;
3593 $fail = 1 if $last_bs;
3595 } elsif ($c eq $close) {
3596 $fail = 1 if $last_bs;
3604 $last_bs = $c eq '\\';
3606 $fail = 1 if $cnt != 0;
3607 return ($open, "$open$str$close") if not $fail;
3613 my($q, $default, $str) = @_;
3614 return "$default$str$default" if $default and index($str, $default) == -1;
3616 (my $succeed, $str) = balanced_delim($str);
3617 return "$q$str" if $succeed;
3619 for my $delim ('/', '"', '#') {
3620 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
3623 $str =~ s/$default/\\$default/g;
3624 return "$default$str$default";
3632 BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
3634 # Split a floating point number into an integer mantissa and a binary
3635 # exponent. Assumes you've already made sure the number isn't zero or
3636 # some weird infinity or NaN.
3640 if ($f == int($f)) {
3641 while ($f % 2 == 0) {
3646 while ($f != int($f)) {
3651 my $mantissa = sprintf("%.0f", $f);
3652 return ($mantissa, $exponent);
3658 if ($self->{'use_dumper'}) {
3659 return $self->const_dumper($sv, $cx);
3661 if (class($sv) eq "SPECIAL") {
3662 # sv_undef, sv_yes, sv_no
3663 return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
3665 if (class($sv) eq "NULL") {
3668 # convert a version object into the "v1.2.3" string in its V magic
3669 if ($sv->FLAGS & SVs_RMG) {
3670 for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
3671 return $mg->PTR if $mg->TYPE eq 'V';
3675 if ($sv->FLAGS & SVf_IOK) {
3676 my $str = $sv->int_value;
3677 $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
3679 } elsif ($sv->FLAGS & SVf_NOK) {
3682 if (pack("F", $nv) eq pack("F", 0)) {
3687 return $self->maybe_parens("-.0", $cx, 21);
3689 } elsif (1/$nv == 0) {
3692 return $self->maybe_parens("9**9**9", $cx, 22);
3695 return $self->maybe_parens("-9**9**9", $cx, 21);
3697 } elsif ($nv != $nv) {
3699 if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
3701 return "sin(9**9**9)";
3702 } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
3704 return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
3707 my $hex = unpack("h*", pack("F", $nv));
3708 return qq'unpack("F", pack("h*", "$hex"))';
3711 # first, try the default stringification
3714 # failing that, try using more precision
3715 $str = sprintf("%.${max_prec}g", $nv);
3716 # if (pack("F", $str) ne pack("F", $nv)) {
3718 # not representable in decimal with whatever sprintf()
3719 # and atof() Perl is using here.
3720 my($mant, $exp) = split_float($nv);
3721 return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
3724 $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
3726 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
3728 if (class($ref) eq "AV") {
3729 return "[" . $self->list_const(2, $ref->ARRAY) . "]";
3730 } elsif (class($ref) eq "HV") {
3731 my %hash = $ref->ARRAY;
3733 for my $k (sort keys %hash) {
3734 push @elts, "$k => " . $self->const($hash{$k}, 6);
3736 return "{" . join(", ", @elts) . "}";
3737 } elsif (class($ref) eq "CV") {
3738 return "sub " . $self->deparse_sub($ref);
3740 if ($ref->FLAGS & SVs_SMG) {
3741 for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
3742 if ($mg->TYPE eq 'r') {
3743 my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
3744 return single_delim("qr", "", $re);
3749 return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
3750 } elsif ($sv->FLAGS & SVf_POK) {
3752 if ($str =~ /[[:^print:]]/) {
3753 return single_delim("qq", '"', uninterp escape_str unback $str);
3755 return single_delim("q", "'", unback $str);
3765 my $ref = $sv->object_2svref();
3766 my $dumper = Data::Dumper->new([$$ref], ['$v']);
3767 $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
3768 my $str = $dumper->Dump();
3769 if ($str =~ /^\$v/) {
3770 return '${my ' . $str . ' \$v}';
3780 # the constant could be in the pad (under useithreads)
3781 $sv = $self->padval($op->targ) unless $$sv;
3788 if ($op->private & OPpCONST_ARYBASE) {
3791 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
3792 # return $self->const_sv($op)->PV;
3794 my $sv = $self->const_sv($op);
3795 return $self->const($sv, $cx);
3801 my $type = $op->name;
3802 if ($type eq "const") {
3803 return '$[' if $op->private & OPpCONST_ARYBASE;
3804 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
3805 } elsif ($type eq "concat") {
3806 my $first = $self->dq($op->first);
3807 my $last = $self->dq($op->last);
3809 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
3810 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
3811 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
3812 || ($last =~ /^[:'{\[\w_]/ && #'
3813 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
3815 return $first . $last;
3816 } elsif ($type eq "uc") {
3817 return '\U' . $self->dq($op->first->sibling) . '\E';
3818 } elsif ($type eq "lc") {
3819 return '\L' . $self->dq($op->first->sibling) . '\E';
3820 } elsif ($type eq "ucfirst") {
3821 return '\u' . $self->dq($op->first->sibling);
3822 } elsif ($type eq "lcfirst") {
3823 return '\l' . $self->dq($op->first->sibling);
3824 } elsif ($type eq "quotemeta") {
3825 return '\Q' . $self->dq($op->first->sibling) . '\E';
3826 } elsif ($type eq "join") {
3827 return $self->deparse($op->last, 26); # was join($", @ary)
3829 return $self->deparse($op, 26);
3836 # skip pushmark if it exists (readpipe() vs ``)
3837 my $child = $op->first->sibling->isa('B::NULL')
3838 ? $op->first : $op->first->sibling;
3839 return single_delim("qx", '`', $self->dq($child));
3845 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
3846 return $self->deparse($kid, $cx) if $self->{'unquote'};
3847 $self->maybe_targmy($kid, $cx,
3848 sub {single_delim("qq", '"', $self->dq($_[1]))});
3851 # OP_STRINGIFY is a listop, but it only ever has one arg
3852 sub pp_stringify { maybe_targmy(@_, \&dquote) }
3854 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
3855 # note that tr(from)/to/ is OK, but not tr/from/(to)
3857 my($from, $to) = @_;
3858 my($succeed, $delim);
3859 if ($from !~ m[/] and $to !~ m[/]) {
3860 return "/$from/$to/";
3861 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
3862 if (($succeed, $to) = balanced_delim($to) and $succeed) {
3865 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
3866 return "$from$delim$to$delim" if index($to, $delim) == -1;
3869 return "$from/$to/";
3872 for $delim ('/', '"', '#') { # note no '
3873 return "$delim$from$delim$to$delim"
3874 if index($to . $from, $delim) == -1;
3876 $from =~ s[/][\\/]g;
3878 return "/$from/$to/";
3882 # Only used by tr///, so backslashes hyphens
3885 if ($n == ord '\\') {
3887 } elsif ($n == ord "-") {
3889 } elsif ($n >= ord(' ') and $n <= ord('~')) {
3891 } elsif ($n == ord "\a") {
3893 } elsif ($n == ord "\b") {
3895 } elsif ($n == ord "\t") {
3897 } elsif ($n == ord "\n") {
3899 } elsif ($n == ord "\e") {
3901 } elsif ($n == ord "\f") {
3903 } elsif ($n == ord "\r") {
3905 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3906 return '\\c' . chr(ord("@") + $n);
3908 # return '\x' . sprintf("%02x", $n);
3909 return '\\' . sprintf("%03o", $n);
3915 my($str, $c, $tr) = ("");
3916 for ($c = 0; $c < @chars; $c++) {
3919 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3920 $chars[$c + 2] == $tr + 2)
3922 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3925 $str .= pchr($chars[$c]);
3931 sub tr_decode_byte {
3932 my($table, $flags) = @_;
3933 my(@table) = unpack("s*", $table);
3934 splice @table, 0x100, 1; # Number of subsequent elements
3935 my($c, $tr, @from, @to, @delfrom, $delhyphen);
3936 if ($table[ord "-"] != -1 and
3937 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3939 $tr = $table[ord "-"];
3940 $table[ord "-"] = -1;
3944 } else { # -2 ==> delete
3948 for ($c = 0; $c < @table; $c++) {
3951 push @from, $c; push @to, $tr;
3952 } elsif ($tr == -2) {
3956 @from = (@from, @delfrom);
3957 if ($flags & OPpTRANS_COMPLEMENT) {
3960 @from{@from} = (1) x @from;
3961 for ($c = 0; $c < 256; $c++) {
3962 push @newfrom, $c unless $from{$c};
3966 unless ($flags & OPpTRANS_DELETE || !@to) {
3967 pop @to while $#to and $to[$#to] == $to[$#to -1];
3970 $from = collapse(@from);
3971 $to = collapse(@to);
3972 $from .= "-" if $delhyphen;
3973 return ($from, $to);
3978 if ($x == ord "-") {
3980 } elsif ($x == ord "\\") {
3987 # XXX This doesn't yet handle all cases correctly either
3989 sub tr_decode_utf8 {
3990 my($swash_hv, $flags) = @_;
3991 my %swash = $swash_hv->ARRAY;
3993 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3994 my $none = $swash{"NONE"}->IV;
3995 my $extra = $none + 1;
3996 my(@from, @delfrom, @to);
3998 foreach $line (split /\n/, $swash{'LIST'}->PV) {
3999 my($min, $max, $result) = split(/\t/, $line);
4006 $result = hex $result;
4007 if ($result == $extra) {
4008 push @delfrom, [$min, $max];
4010 push @from, [$min, $max];
4011 push @to, [$result, $result + $max - $min];
4014 for my $i (0 .. $#from) {
4015 if ($from[$i][0] == ord '-') {
4016 unshift @from, splice(@from, $i, 1);
4017 unshift @to, splice(@to, $i, 1);
4019 } elsif ($from[$i][1] == ord '-') {
4022 unshift @from, ord '-';
4023 unshift @to, ord '-';
4027 for my $i (0 .. $#delfrom) {
4028 if ($delfrom[$i][0] == ord '-') {
4029 push @delfrom, splice(@delfrom, $i, 1);
4031 } elsif ($delfrom[$i][1] == ord '-') {
4033 push @delfrom, ord '-';
4037 if (defined $final and $to[$#to][1] != $final) {
4038 push @to, [$final, $final];
4040 push @from, @delfrom;
4041 if ($flags & OPpTRANS_COMPLEMENT) {
4044 for my $i (0 .. $#from) {
4045 push @newfrom, [$next, $from[$i][0] - 1];
4046 $next = $from[$i][1] + 1;
4049 for my $range (@newfrom) {
4050 if ($range->[0] <= $range->[1]) {
4055 my($from, $to, $diff);
4056 for my $chunk (@from) {
4057 $diff = $chunk->[1] - $chunk->[0];
4059 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
4060 } elsif ($diff == 1) {
4061 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
4063 $from .= tr_chr($chunk->[0]);
4066 for my $chunk (@to) {
4067 $diff = $chunk->[1] - $chunk->[0];
4069 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
4070 } elsif ($diff == 1) {
4071 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
4073 $to .= tr_chr($chunk->[0]);
4076 #$final = sprintf("%04x", $final) if defined $final;
4077 #$none = sprintf("%04x", $none) if defined $none;
4078 #$extra = sprintf("%04x", $extra) if defined $extra;
4079 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
4080 #print STDERR $swash{'LIST'}->PV;
4081 return (escape_str($from), escape_str($to));
4088 if (class($op) eq "PVOP") {
4089 ($from, $to) = tr_decode_byte($op->pv, $op->private);
4090 } else { # class($op) eq "SVOP"
4091 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
4094 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
4095 $flags .= "d" if $op->private & OPpTRANS_DELETE;
4096 $to = "" if $from eq $to and $flags eq "";
4097 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
4098 return "tr" . double_delim($from, $to) . $flags;
4101 sub re_dq_disambiguate {
4102 my ($first, $last) = @_;
4103 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
4104 ($last =~ /^[A-Z\\\^\[\]_?]/ &&
4105 $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
4106 || ($last =~ /^[{\[\w_]/ &&
4107 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
4108 return $first . $last;
4111 # Like dq(), but different
4114 my ($op, $extended) = @_;
4116 my $type = $op->name;
4117 if ($type eq "const") {
4118 return '$[' if $op->private & OPpCONST_ARYBASE;
4119 my $unbacked = re_unback($self->const_sv($op)->as_string);
4120 return re_uninterp_extended(escape_extended_re($unbacked))
4122 return re_uninterp(escape_str($unbacked));
4123 } elsif ($type eq "concat") {
4124 my $first = $self->re_dq($op->first, $extended);
4125 my $last = $self->re_dq($op->last, $extended);
4126 return re_dq_disambiguate($first, $last);
4127 } elsif ($type eq "uc") {
4128 return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
4129 } elsif ($type eq "lc") {
4130 return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
4131 } elsif ($type eq "ucfirst") {
4132 return '\u' . $self->re_dq($op->first->sibling, $extended);
4133 } elsif ($type eq "lcfirst") {
4134 return '\l' . $self->re_dq($op->first->sibling, $extended);
4135 } elsif ($type eq "quotemeta") {
4136 return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
4137 } elsif ($type eq "join") {
4138 return $self->deparse($op->last, 26); # was join($", @ary)
4140 return $self->deparse($op, 26);
4145 my ($self, $op) = @_;
4146 return 0 if null $op;
4147 my $type = $op->name;
4149 if ($type eq 'const') {
4152 elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
4153 return $self->pure_string($op->first->sibling);
4155 elsif ($type eq 'join') {
4156 my $join_op = $op->first->sibling; # Skip pushmark
4157 return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
4159 my $gvop = $join_op->first;
4160 return 0 unless $gvop->name eq 'gvsv';
4161 return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
4163 return 0 unless ${$join_op->sibling} eq ${$op->last};
4164 return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
4166 elsif ($type eq 'concat') {
4167 return $self->pure_string($op->first)
4168 && $self->pure_string($op->last);
4170 elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
4173 elsif ($type eq "null" and $op->can('first') and not null $op->first and
4174 $op->first->name eq "null" and $op->first->can('first')
4175 and not null $op->first->first and
4176 $op->first->first->name eq "aelemfast") {
4188 my($op, $cx, $extended) = @_;
4189 my $kid = $op->first;
4190 $kid = $kid->first if $kid->name eq "regcmaybe";
4191 $kid = $kid->first if $kid->name eq "regcreset";
4192 if ($kid->name eq "null" and !null($kid->first)
4193 and $kid->first->name eq 'pushmark')
4196 $kid = $kid->first->sibling;
4197 while (!null($kid)) {
4199 my $last = $self->re_dq($kid, $extended);
4200 $str = re_dq_disambiguate($first, $last);
4201 $kid = $kid->sibling;
4206 return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
4207 return ($self->deparse($kid, $cx), 0);
4211 my ($self, $op, $cx) = @_;
4212 return (($self->regcomp($op, $cx, 0))[0]);
4215 # osmic acid -- see osmium tetroxide
4218 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
4219 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
4220 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
4224 my($op, $cx, $name, $delim) = @_;
4225 my $kid = $op->first;
4226 my ($binop, $var, $re) = ("", "", "");
4227 if ($op->flags & OPf_STACKED) {
4229 $var = $self->deparse($kid, 20);
4230 $kid = $kid->sibling;
4233 my $extended = ($op->pmflags & PMf_EXTENDED);
4234 my $rhs_bound_to_defsv;
4236 my $unbacked = re_unback($op->precomp);
4238 $re = re_uninterp_extended(escape_extended_re($unbacked));
4240 $re = re_uninterp(escape_str(re_unback($op->precomp)));
4242 } elsif ($kid->name ne 'regcomp') {
4243 carp("found ".$kid->name." where regcomp expected");
4245 ($re, $quote) = $self->regcomp($kid, 21, $extended);
4246 $rhs_bound_to_defsv = 1 if $kid->first->first->flags & OPf_SPECIAL;
4249 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
4250 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
4251 $flags .= "i" if $op->pmflags & PMf_FOLD;
4252 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
4253 $flags .= "o" if $op->pmflags & PMf_KEEP;
4254 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
4255 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
4256 $flags = $matchwords{$flags} if $matchwords{$flags};
4257 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
4261 $re = single_delim($name, $delim, $re);
4263 $re = $re . $flags if $quote;
4266 $self->maybe_parens(
4268 ? "$var =~ (\$_ =~ $re)"
4277 sub pp_match { matchop(@_, "m", "/") }
4278 sub pp_pushre { matchop(@_, "m", "/") }
4279 sub pp_qr { matchop(@_, "qr", "") }
4284 my($kid, @exprs, $ary, $expr);
4287 # For our kid (an OP_PUSHRE), pmreplroot is never actually the
4288 # root of a replacement; it's either empty, or abused to point to
4289 # the GV for an array we split into (an optimization to save
4290 # assignment overhead). Depending on whether we're using ithreads,
4291 # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
4292 # figures out for us which it is.
4293 my $replroot = $kid->pmreplroot;
4295 if (ref($replroot) eq "B::GV") {
4297 } elsif (!ref($replroot) and $replroot > 0) {
4298 $gv = $self->padval($replroot);
4300 $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
4302 for (; !null($kid); $kid = $kid->sibling) {
4303 push @exprs, $self->deparse($kid, 6);
4306 # handle special case of split(), and split(' ') that compiles to /\s+/
4307 # Under 5.10, the reflags may be undef if the split regexp isn't a constant
4309 if ( $kid->flags & OPf_SPECIAL
4310 and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
4311 : ($kid->reflags || 0) & RXf_SKIPWHITE() ) ) {
4315 $expr = "split(" . join(", ", @exprs) . ")";
4317 return $self->maybe_parens("$ary = $expr", $cx, 7);
4323 # oxime -- any of various compounds obtained chiefly by the action of
4324 # hydroxylamine on aldehydes and ketones and characterized by the
4325 # bivalent grouping C=NOH [Webster's Tenth]
4328 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
4329 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
4330 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
4331 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi',
4332 'sir', 'rise', 'smore', 'more', 'seer', 'rome', 'gore', 'grim', 'grime',
4333 'or', 'rose', 'rosie');
4338 my $kid = $op->first;
4339 my($binop, $var, $re, $repl) = ("", "", "", "");
4340 if ($op->flags & OPf_STACKED) {
4342 $var = $self->deparse($kid, 20);
4343 $kid = $kid->sibling;
4346 if (null($op->pmreplroot)) {
4347 $repl = $self->dq($kid);
4348 $kid = $kid->sibling;
4350 $repl = $op->pmreplroot->first; # skip substcont
4351 while ($repl->name eq "entereval") {
4352 $repl = $repl->first;
4355 if ($op->pmflags & PMf_EVAL) {
4356 $repl = $self->deparse($repl->first, 0);
4358 $repl = $self->dq($repl);
4361 my $extended = ($op->pmflags & PMf_EXTENDED);
4363 my $unbacked = re_unback($op->precomp);
4365 $re = re_uninterp_extended(escape_extended_re($unbacked));
4368 $re = re_uninterp(escape_str($unbacked));
4371 ($re) = $self->regcomp($kid, 1, $extended);
4373 $flags .= "e" if $op->pmflags & PMf_EVAL;