2 # Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
3 # This module is free software; you can redistribute and/or modify
4 # it under the same terms as Perl itself.
6 # This is based on the module of the same name by Malcolm Beattie,
7 # but essentially none of his code remains.
10 use Carp 'cluck', 'croak';
11 use B qw(class main_root main_start main_cv svref_2object opnumber cstring
12 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
13 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
14 OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
15 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
16 OPpCONST_ARYBASE OPpEXISTS_SUB
17 SVf_IOK SVf_NOK SVf_ROK SVf_POK
18 CVf_METHOD CVf_LOCKED CVf_LVALUE
19 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE
20 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
25 # Changes between 0.50 and 0.51:
26 # - fixed nulled leave with live enter in sort { }
27 # - fixed reference constants (\"str")
28 # - handle empty programs gracefully
29 # - handle infinte loops (for (;;) {}, while (1) {})
30 # - differentiate between `for my $x ...' and `my $x; for $x ...'
31 # - various minor cleanups
32 # - moved globals into an object
33 # - added `-u', like B::C
34 # - package declarations using cop_stash
35 # - subs, formats and code sorted by cop_seq
36 # Changes between 0.51 and 0.52:
37 # - added pp_threadsv (special variables under USE_THREADS)
38 # - added documentation
39 # Changes between 0.52 and 0.53:
40 # - many changes adding precedence contexts and associativity
41 # - added `-p' and `-s' output style options
42 # - various other minor fixes
43 # Changes between 0.53 and 0.54:
44 # - added support for new `for (1..100)' optimization,
46 # Changes between 0.54 and 0.55:
47 # - added support for new qr// construct
48 # - added support for new pp_regcreset OP
49 # Changes between 0.55 and 0.56:
50 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
51 # - fixed $# on non-lexicals broken in last big rewrite
52 # - added temporary fix for change in opcode of OP_STRINGIFY
53 # - fixed problem in 0.54's for() patch in `for (@ary)'
54 # - fixed precedence in conditional of ?:
55 # - tweaked list paren elimination in `my($x) = @_'
56 # - made continue-block detection trickier wrt. null ops
57 # - fixed various prototype problems in pp_entersub
58 # - added support for sub prototypes that never get GVs
59 # - added unquoting for special filehandle first arg in truncate
60 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
61 # - added semicolons at the ends of blocks
62 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
63 # Changes between 0.56 and 0.561:
64 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
65 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
66 # Changes between 0.561 and 0.57:
67 # - stylistic changes to symbolic constant stuff
68 # - handled scope in s///e replacement code
69 # - added unquote option for expanding "" into concats, etc.
70 # - split method and proto parts of pp_entersub into separate functions
71 # - various minor cleanups
73 # - added parens in \&foo (patch by Albert Dvornik)
74 # Changes between 0.57 and 0.58:
75 # - fixed `0' statements that weren't being printed
76 # - added methods for use from other programs
77 # (based on patches from James Duncan and Hugo van der Sanden)
78 # - added -si and -sT to control indenting (also based on a patch from Hugo)
79 # - added -sv to print something else instead of '???'
80 # - preliminary version of utf8 tr/// handling
82 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
83 # - added support for Hugo's new OP_SETSTATE (like nextstate)
84 # Changes between 0.58 and 0.59
85 # - added support for Chip's OP_METHOD_NAMED
86 # - added support for Ilya's OPpTARGET_MY optimization
87 # - elided arrows before `()' subscripts when possible
88 # Changes between 0.59 and 0.60
89 # - support for method attribues was added
90 # - some warnings fixed
91 # - separate recognition of constant subs
92 # - rewrote continue block handling, now recoginizing for loops
93 # - added more control of expanding control structures
96 # - finish tr/// changes
97 # - add option for even more parens (generalize \&foo change)
98 # - left/right context
99 # - treat top-level block specially for incremental output
100 # - copy comments (look at real text with $^P?)
101 # - avoid semis in one-statement blocks
102 # - associativity of &&=, ||=, ?:
103 # - ',' => '=>' (auto-unquote?)
104 # - break long lines ("\r" as discretionary break?)
105 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
106 # - more style options: brace style, hex vs. octal, quotes, ...
107 # - print big ints as hex/octal instead of decimal (heuristic?)
108 # - handle `my $x if 0'?
109 # - coordinate with Data::Dumper (both directions? see previous)
110 # - version using op_next instead of op_first/sibling?
111 # - avoid string copies (pass arrays, one big join?)
114 # Tests that will always fail:
115 # comp/redef.t -- all (redefinition happens at compile time)
117 # Object fields (were globals):
120 # (local($a), local($b)) and local($a, $b) have the same internal
121 # representation but the short form looks better. We notice we can
122 # use a large-scale local when checking the list, but need to prevent
123 # individual locals too. This hash holds the addresses of OPs that
124 # have already had their local-ness accounted for. The same thing
128 # CV for current sub (or main program) being deparsed
131 # Cached hash of lexical variables for curcv: keys are names,
132 # each value is an array of pairs, indicating the cop_seq of scopes
133 # in which a var of that name is valid.
136 # COP for statement being deparsed
139 # name of the current package for deparsed code
142 # array of [cop_seq, CV, is_format?] for subs and formats we still
146 # as above, but [name, prototype] for subs that never got a GV
148 # subs_done, forms_done:
149 # keys are addresses of GVs for subs and formats we've already
150 # deparsed (or at least put into subs_todo)
153 # keys are names of subs for which we've printed declarations.
154 # That means we can omit parentheses from the arguments.
159 # cuddle: ` ' or `\n', depending on -sC
164 # A little explanation of how precedence contexts and associativity
167 # deparse() calls each per-op subroutine with an argument $cx (short
168 # for context, but not the same as the cx* in the perl core), which is
169 # a number describing the op's parents in terms of precedence, whether
170 # they're inside an expression or at statement level, etc. (see
171 # chart below). When ops with children call deparse on them, they pass
172 # along their precedence. Fractional values are used to implement
173 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
174 # parentheses hacks. The major disadvantage of this scheme is that
175 # it doesn't know about right sides and left sides, so say if you
176 # assign a listop to a variable, it can't tell it's allowed to leave
177 # the parens off the listop.
180 # 26 [TODO] inside interpolation context ("")
181 # 25 left terms and list operators (leftward)
185 # 21 right ! ~ \ and unary + and -
190 # 16 nonassoc named unary operators
191 # 15 nonassoc < > <= >= lt gt le ge
192 # 14 nonassoc == != <=> eq ne cmp
199 # 7 right = += -= *= etc.
201 # 5 nonassoc list operators (rightward)
205 # 1 statement modifiers
208 # Nonprinting characters with special meaning:
209 # \cS - steal parens (see maybe_parens_unop)
210 # \n - newline and indent
211 # \t - increase indent
212 # \b - decrease indent (`outdent')
213 # \f - flush left (no indent)
214 # \cK - kill following semicolon, if any
218 return class($op) eq "NULL";
223 my($cv, $is_form) = @_;
224 return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
226 if (!null($cv->START) and is_state($cv->START)) {
227 $seq = $cv->START->cop_seq;
231 push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
236 my $ent = shift @{$self->{'subs_todo'}};
239 my $name = $self->gv_name($gv);
241 return "format $name =\n"
242 . $self->deparse_format($ent->[1]). "\n";
244 $self->{'subs_declared'}{$name} = 1;
245 if ($name eq "BEGIN") {
246 my $use_dec = $self->begin_is_use($cv);
247 if (defined ($use_dec)) {
248 return () if 0 == length($use_dec);
252 return "sub $name " . $self->deparse_sub($cv);
256 # Return a "use" declaration for this BEGIN block, if appropriate
258 my ($self, $cv) = @_;
259 my $root = $cv->ROOT;
261 #B::walkoptree($cv->ROOT, "debug");
262 my $lineseq = $root->first;
263 return if $lineseq->name ne "lineseq";
265 my $req_op = $lineseq->first->sibling;
266 return if $req_op->name ne "require";
269 if ($req_op->first->private & OPpCONST_BARE) {
270 # Actually it should always be a bareword
271 $module = $self->const_sv($req_op->first)->PV;
272 $module =~ s[/][::]g;
276 $module = const($self->const_sv($req_op->first));
280 my $version_op = $req_op->sibling;
281 return if class($version_op) eq "NULL";
282 if ($version_op->name eq "lineseq") {
283 # We have a version parameter; skip nextstate & pushmark
284 my $constop = $version_op->first->next->next;
286 return unless $self->const_sv($constop)->PV eq $module;
287 $constop = $constop->sibling;
289 $version = $self->const_sv($constop)->int_value;
290 $constop = $constop->sibling;
291 return if $constop->name ne "method_named";
292 return if $self->const_sv($constop)->PV ne "VERSION";
295 $lineseq = $version_op->sibling;
296 return if $lineseq->name ne "lineseq";
297 my $entersub = $lineseq->first->sibling;
298 if ($entersub->name eq "stub") {
299 return "use $module $version ();\n" if defined $version;
300 return "use $module ();\n";
302 return if $entersub->name ne "entersub";
304 # See if there are import arguments
307 my $constop = $entersub->first->sibling; # Skip over pushmark
308 return unless $self->const_sv($constop)->PV eq $module;
310 # Pull out the arguments
311 for ($constop=$constop->sibling; $constop->name eq "const";
312 $constop = $constop->sibling) {
313 $args .= ", " if length($args);
314 $args .= $self->deparse($constop, 6);
318 my $method_named = $constop;
319 return if $method_named->name ne "method_named";
320 my $method_name = $self->const_sv($method_named)->PV;
322 if ($method_name eq "unimport") {
326 # Certain pragmas are dealt with using hint bits,
327 # so we ignore them here
328 if ($module eq 'strict' || $module eq 'integer'
329 || $module eq 'bytes' || $module eq 'warnings') {
333 if (defined $version && length $args) {
334 return "$use $module $version ($args);\n";
335 } elsif (defined $version) {
336 return "$use $module $version;\n";
337 } elsif (length $args) {
338 return "$use $module ($args);\n";
340 return "$use $module;\n";
345 my ($self, $pack) = @_;
347 if (!defined $pack) {
352 $pack =~ s/(::)?$/::/;
356 my %stash = svref_2object($stash)->ARRAY;
357 while (my ($key, $val) = each %stash) {
358 next if $key eq 'main::'; # avoid infinite recursion
359 my $class = class($val);
360 if ($class eq "PV") {
362 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
363 } elsif ($class eq "IV") {
365 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
366 } elsif ($class eq "GV") {
367 if (class(my $cv = $val->CV) ne "SPECIAL") {
368 next if $self->{'subs_done'}{$$val}++;
369 next if $$val != ${$cv->GV}; # Ignore imposters
372 if (class(my $cv = $val->FORM) ne "SPECIAL") {
373 next if $self->{'forms_done'}{$$val}++;
374 next if $$val != ${$cv->GV}; # Ignore imposters
377 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
378 $self->stash_subs($pack . $key);
388 foreach $ar (@{$self->{'protos_todo'}}) {
389 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
390 push @ret, "sub " . $ar->[0] . "$proto;\n";
392 delete $self->{'protos_todo'};
400 while (length($opt = substr($opts, 0, 1))) {
402 $self->{'cuddle'} = " ";
403 $opts = substr($opts, 1);
404 } elsif ($opt eq "i") {
405 $opts =~ s/^i(\d+)//;
406 $self->{'indent_size'} = $1;
407 } elsif ($opt eq "T") {
408 $self->{'use_tabs'} = 1;
409 $opts = substr($opts, 1);
410 } elsif ($opt eq "v") {
411 $opts =~ s/^v([^.]*)(.|$)//;
412 $self->{'ex_const'} = $1;
419 my $self = bless {}, $class;
420 $self->{'subs_todo'} = [];
421 $self->{'files'} = {};
422 $self->{'curstash'} = "main";
423 $self->{'curcop'} = undef;
424 $self->{'cuddle'} = "\n";
425 $self->{'indent_size'} = 4;
426 $self->{'use_tabs'} = 0;
427 $self->{'expand'} = 0;
428 $self->{'unquote'} = 0;
429 $self->{'linenums'} = 0;
430 $self->{'parens'} = 0;
431 $self->{'ex_const'} = "'???'";
433 $self->{'ambient_arybase'} = 0;
434 $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
435 $self->{'ambient_hints'} = 0;
438 while (my $arg = shift @_) {
439 if ($arg =~ /^-f(.*)/) {
440 $self->{'files'}{$1} = 1;
441 } elsif ($arg eq "-p") {
442 $self->{'parens'} = 1;
443 } elsif ($arg eq "-l") {
444 $self->{'linenums'} = 1;
445 } elsif ($arg eq "-q") {
446 $self->{'unquote'} = 1;
447 } elsif (substr($arg, 0, 2) eq "-s") {
448 $self->style_opts(substr $arg, 2);
449 } elsif ($arg =~ /^-x(\d)$/) {
450 $self->{'expand'} = $1;
457 # Mask out the bits that C<use vars> uses
458 $warnings::Bits{all} | $warnings::DeadBits{all};
461 # Initialise the contextual information, either from
462 # defaults provided with the ambient_pragmas method,
463 # or from perl's own defaults otherwise.
467 $self->{'arybase'} = $self->{'ambient_arybase'};
468 $self->{'warnings'} = defined ($self->{'ambient_warnings'})
469 ? $self->{'ambient_warnings'} & WARN_MASK
471 $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
473 # also a convenient place to clear out subs_declared
474 delete $self->{'subs_declared'};
480 my $self = B::Deparse->new(@args);
481 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
482 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
483 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
484 for my $block (@BEGINs, @INITs, @ENDs) {
485 $self->todo($block, 0);
488 $self->{'curcv'} = main_cv;
489 $self->{'curcvlex'} = undef;
490 print $self->print_protos;
491 @{$self->{'subs_todo'}} =
492 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
493 print $self->indent($self->deparse(main_root, 0)), "\n"
494 unless null main_root;
496 while (scalar(@{$self->{'subs_todo'}})) {
497 push @text, $self->next_todo;
499 print $self->indent(join("", @text)), "\n" if @text;
501 # Print __DATA__ section, if necessary
503 if (defined *{$self->{'curstash'}."::DATA"}{IO}) {
505 print readline(*{$self->{'curstash'}."::DATA"});
513 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
516 return $self->indent($self->deparse_sub(svref_2object($sub)));
519 sub ambient_pragmas {
521 my ($arybase, $hint_bits, $warning_bits) = (0, 0);
527 if ($name eq 'strict') {
530 if ($val eq 'none') {
531 $hint_bits &= ~strict::bits(qw/refs subs vars/);
537 @names = qw/refs subs vars/;
543 @names = split' ', $val;
545 $hint_bits |= strict::bits(@names);
548 elsif ($name eq '$[') {
552 elsif ($name eq 'integer'
554 || $name eq 'utf8') {
557 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
560 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
564 elsif ($name eq 're') {
566 if ($val eq 'none') {
567 $hint_bits &= ~re::bits(qw/taint eval asciirange/);
573 @names = qw/taint eval asciirange/;
579 @names = split' ',$val;
581 $hint_bits |= re::bits(@names);
584 elsif ($name eq 'warnings') {
585 if ($val eq 'none') {
586 $warning_bits = "\0"x12;
595 @names = split/\s+/, $val;
598 $warning_bits = "\0"x12 if !defined ($warning_bits);
599 $warning_bits |= warnings::bits(@names);
602 elsif ($name eq 'warning_bits') {
603 $warning_bits = $val;
606 elsif ($name eq 'hint_bits') {
611 croak "Unknown pragma type: $name";
615 croak "The ambient_pragmas method expects an even number of args";
618 $self->{'ambient_arybase'} = $arybase;
619 $self->{'ambient_warnings'} = $warning_bits;
620 $self->{'ambient_hints'} = $hint_bits;
627 Carp::confess("Null op in deparse") if !defined($op)
628 || class($op) eq "NULL";
629 my $meth = "pp_" . $op->name;
630 return $self->$meth($op, $cx);
636 my @lines = split(/\n/, $txt);
641 my $cmd = substr($line, 0, 1);
642 if ($cmd eq "\t" or $cmd eq "\b") {
643 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
644 if ($self->{'use_tabs'}) {
645 $leader = "\t" x ($level / 8) . " " x ($level % 8);
647 $leader = " " x $level;
649 $line = substr($line, 1);
651 if (substr($line, 0, 1) eq "\f") {
652 $line = substr($line, 1); # no indent
654 $line = $leader . $line;
658 return join("\n", @lines);
665 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
666 local $self->{'curcop'} = $self->{'curcop'};
667 if ($cv->FLAGS & SVf_POK) {
668 $proto = "(". $cv->PV . ") ";
670 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
672 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
673 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
674 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
677 local($self->{'curcv'}) = $cv;
678 local($self->{'curcvlex'});
679 local(@$self{qw'curstash warnings hints'})
680 = @$self{qw'curstash warnings hints'};
681 if (not null $cv->ROOT) {
683 return $proto . "{\n\t" .
684 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
686 my $sv = $cv->const_sv;
688 # uh-oh. inlinable sub... format it differently
689 return $proto . "{ " . const($sv) . " }\n";
690 } else { # XSUB? (or just a declaration)
699 local($self->{'curcv'}) = $form;
700 local($self->{'curcvlex'});
701 local(@$self{qw'curstash warnings hints'})
702 = @$self{'curstash warnings hints'};
703 my $op = $form->ROOT;
705 $op = $op->first->first; # skip leavewrite, lineseq
706 while (not null $op) {
707 $op = $op->sibling; # skip nextstate
709 $kid = $op->first->sibling; # skip pushmark
710 push @text, $self->const_sv($kid)->PV;
711 $kid = $kid->sibling;
712 for (; not null $kid; $kid = $kid->sibling) {
713 push @exprs, $self->deparse($kid, 0);
715 push @text, join(", ", @exprs)."\n" if @exprs;
718 return join("", @text) . ".";
723 return $op->name eq "leave" || $op->name eq "scope"
724 || $op->name eq "lineseq"
725 || ($op->name eq "null" && class($op) eq "UNOP"
726 && (is_scope($op->first) || $op->first->name eq "enter"));
730 my $name = $_[0]->name;
731 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
734 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
736 return (!null($op) and null($op->sibling)
737 and $op->name eq "null" and class($op) eq "UNOP"
738 and (($op->first->name =~ /^(and|or)$/
739 and $op->first->first->sibling->name eq "lineseq")
740 or ($op->first->name eq "lineseq"
741 and not null $op->first->first->sibling
742 and $op->first->first->sibling->name eq "unstack")
748 return ($op->name eq "rv2sv" or
749 $op->name eq "padsv" or
750 $op->name eq "gv" or # only in array/hash constructs
751 $op->flags & OPf_KIDS && !null($op->first)
752 && $op->first->name eq "gvsv");
757 my($text, $cx, $prec) = @_;
758 if ($prec < $cx # unary ops nest just fine
759 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
760 or $self->{'parens'})
763 # In a unop, let parent reuse our parens; see maybe_parens_unop
764 $text = "\cS" . $text if $cx == 16;
771 # same as above, but get around the `if it looks like a function' rule
772 sub maybe_parens_unop {
774 my($name, $kid, $cx) = @_;
775 if ($cx > 16 or $self->{'parens'}) {
776 return "$name(" . $self->deparse($kid, 1) . ")";
778 $kid = $self->deparse($kid, 16);
779 if (substr($kid, 0, 1) eq "\cS") {
781 return $name . substr($kid, 1);
782 } elsif (substr($kid, 0, 1) eq "(") {
783 # avoid looks-like-a-function trap with extra parens
784 # (`+' can lead to ambiguities)
785 return "$name(" . $kid . ")";
792 sub maybe_parens_func {
794 my($func, $text, $cx, $prec) = @_;
795 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
796 return "$func($text)";
798 return "$func $text";
804 my($op, $cx, $text) = @_;
805 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
806 if (want_scalar($op)) {
807 return "local $text";
809 return $self->maybe_parens_func("local", $text, $cx, 16);
818 my($op, $cx, $func, @args) = @_;
819 if ($op->private & OPpTARGET_MY) {
820 my $var = $self->padname($op->targ);
821 my $val = $func->($self, $op, 7, @args);
822 return $self->maybe_parens("$var = $val", $cx, 7);
824 return $func->($self, $op, $cx, @args);
831 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
836 my($op, $cx, $text) = @_;
837 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
838 if (want_scalar($op)) {
841 return $self->maybe_parens_func("my", $text, $cx, 16);
848 # The following OPs don't have functions:
850 # pp_padany -- does not exist after parsing
851 # pp_rcatline -- does not exist
853 sub pp_enter { # see also leave
854 cluck "unexpected OP_ENTER";
858 sub pp_pushmark { # see also list
859 cluck "unexpected OP_PUSHMARK";
863 sub pp_leavesub { # see also deparse_sub
864 cluck "unexpected OP_LEAVESUB";
868 sub pp_leavewrite { # see also deparse_format
869 cluck "unexpected OP_LEAVEWRITE";
873 sub pp_method { # see also entersub
874 cluck "unexpected OP_METHOD";
878 sub pp_regcmaybe { # see also regcomp
879 cluck "unexpected OP_REGCMAYBE";
883 sub pp_regcreset { # see also regcomp
884 cluck "unexpected OP_REGCRESET";
888 sub pp_substcont { # see also subst
889 cluck "unexpected OP_SUBSTCONT";
893 sub pp_grepstart { # see also grepwhile
894 cluck "unexpected OP_GREPSTART";
898 sub pp_mapstart { # see also mapwhile
899 cluck "unexpected OP_MAPSTART";
903 sub pp_flip { # see also flop
904 cluck "unexpected OP_FLIP";
908 sub pp_iter { # see also leaveloop
909 cluck "unexpected OP_ITER";
913 sub pp_enteriter { # see also leaveloop
914 cluck "unexpected OP_ENTERITER";
918 sub pp_enterloop { # see also leaveloop
919 cluck "unexpected OP_ENTERLOOP";
923 sub pp_leaveeval { # see also entereval
924 cluck "unexpected OP_LEAVEEVAL";
928 sub pp_entertry { # see also leavetry
929 cluck "unexpected OP_ENTERTRY";
937 for (my $i = 0; $i < @ops; $i++) {
939 if (is_state $ops[$i]) {
940 $expr = $self->deparse($ops[$i], 0);
944 if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
945 $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
947 push @exprs, $expr . $self->for_loop($ops[$i], 0);
951 $expr .= $self->deparse($ops[$i], 0);
952 push @exprs, $expr if length $expr;
954 for(@exprs[0..@exprs-1]) { s/;\n\z// }
955 return join(";\n", @exprs);
959 my($real_block, $self, $op, $cx) = @_;
963 local(@$self{qw'curstash warnings hints'})
964 = @$self{qw'curstash warnings hints'} if $real_block;
966 $kid = $op->first->sibling; # skip enter
967 if (is_miniwhile($kid)) {
968 my $top = $kid->first;
969 my $name = $top->name;
970 if ($name eq "and") {
972 } elsif ($name eq "or") {
974 } else { # no conditional -> while 1 or until 0
975 return $self->deparse($top->first, 1) . " while 1";
977 my $cond = $top->first;
978 my $body = $cond->sibling->first; # skip lineseq
979 $cond = $self->deparse($cond, 1);
980 $body = $self->deparse($body, 1);
981 return "$body $name $cond";
986 for (; !null($kid); $kid = $kid->sibling) {
989 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
990 return "do { " . $self->lineseq(@kids) . " }";
992 my $lineseq = $self->lineseq(@kids);
993 return (length ($lineseq) ? "$lineseq;" : "");
997 sub pp_scope { scopeop(0, @_); }
998 sub pp_lineseq { scopeop(0, @_); }
999 sub pp_leave { scopeop(1, @_); }
1001 # The BEGIN {} is used here because otherwise this code isn't executed
1002 # when you run B::Deparse on itself.
1004 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1005 "ENV", "ARGV", "ARGVOUT", "_"); }
1010 Carp::confess() if $gv->isa("B::CV");
1011 my $stash = $gv->STASH->NAME;
1012 my $name = $gv->SAFENAME;
1013 if ($stash eq $self->{'curstash'} or $globalnames{$name}
1014 or $name =~ /^[^A-Za-z_]/)
1018 $stash = $stash . "::";
1020 if ($name =~ /^\^../) {
1021 $name = "{$name}"; # ${^WARNING_BITS} etc
1023 return $stash . $name;
1026 # Return the name to use for a stash variable.
1027 # If a lexical with the same name is in scope, it may need to be
1029 sub stash_variable {
1030 my ($self, $prefix, $name) = @_;
1032 return "$prefix$name" if $name =~ /::/;
1034 unless ($prefix eq '$' || $prefix eq '@' ||
1035 $prefix eq '%' || $prefix eq '$#') {
1036 return "$prefix$name";
1039 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1040 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
1041 return "$prefix$name";
1045 my ($self, $name) = @_;
1046 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1048 my $seq = $self->{'curcop'}->cop_seq;
1049 return 0 if !exists $self->{'curcvlex'}{$name};
1050 for my $a (@{$self->{'curcvlex'}{$name}}) {
1051 my ($st, $en) = @$a;
1052 return 1 if $seq > $st && $seq <= $en;
1057 sub populate_curcvlex {
1059 for (my $cv = $self->{'curcv'}; $$cv; $cv = $cv->OUTSIDE) {
1060 my @padlist = $cv->PADLIST->ARRAY;
1061 my @ns = $padlist[0]->ARRAY;
1063 for (my $i=0; $i<@ns; ++$i) {
1064 next if class($ns[$i]) eq "SPECIAL";
1065 if (class($ns[$i]) eq "PV") {
1066 # Probably that pesky lexical @_
1069 my $name = $ns[$i]->PVX;
1070 my $seq_st = $ns[$i]->NVX;
1071 my $seq_en = int($ns[$i]->IVX);
1073 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1078 # Recurses down the tree, looking for a COP
1080 my ($self, $op) = @_;
1081 if ($op->flags & OPf_KIDS) {
1082 for (my $o=$op->first; $$o; $o=$o->sibling) {
1083 return $o if is_state($o);
1084 my $r = $self->find_cop($o);
1085 return $r if defined $r;
1091 # Returns a list of subs which should be inserted before the COP
1093 my ($self, $op, $out_seq) = @_;
1094 my $seq = $op->cop_seq;
1095 # If we have nephews, then our sequence number indicates
1096 # the cop_seq of the end of some sort of scope.
1097 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1098 and my $ncop = $self->find_cop($op->sibling)) {
1099 $seq = $ncop->cop_seq;
1101 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1102 return $self->seq_subs($seq);
1106 my ($self, $seq) = @_;
1108 #push @text, "# ($seq)\n";
1110 while (scalar(@{$self->{'subs_todo'}})
1111 and $seq > $self->{'subs_todo'}[0][0]) {
1112 push @text, $self->next_todo;
1117 # Notice how subs and formats are inserted between statements here;
1118 # also $[ assignments and pragmas.
1122 $self->{'curcop'} = $op;
1124 @text = $op->label . ": " if $op->label;
1125 #push @text, "# ", $op->cop_seq, "\n";
1126 push @text, $self->cop_subs($op);
1127 my $stash = $op->stashpv;
1128 if ($stash ne $self->{'curstash'}) {
1129 push @text, "package $stash;\n";
1130 $self->{'curstash'} = $stash;
1132 if ($self->{'linenums'}) {
1133 push @text, "\f#line " . $op->line .
1134 ' "' . $op->file, qq'"\n';
1137 if ($self->{'arybase'} != $op->arybase) {
1138 push @text, '$[ = '. $op->arybase .";\n";
1139 $self->{'arybase'} = $op->arybase;
1142 my $warnings = $op->warnings;
1144 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1145 $warning_bits = $warnings::Bits{"all"};
1147 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1148 $warning_bits = "\0"x12;
1150 elsif ($warnings->isa("B::SPECIAL")) {
1151 $warning_bits = undef;
1154 $warning_bits = $warnings->PV & WARN_MASK;
1157 if (defined ($warning_bits) and
1158 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1159 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1160 $self->{'warnings'} = $warning_bits;
1163 if ($self->{'hints'} != $op->private) {
1164 push @text, declare_hints($self->{'hints'}, $op->private);
1165 $self->{'hints'} = $op->private;
1168 return join("", @text);
1171 sub declare_warnings {
1172 my ($from, $to) = @_;
1173 if ($to eq warnings::bits("all")) {
1174 return "use warnings;\n";
1176 elsif ($to eq "\0"x12) {
1177 return "no warnings;\n";
1179 return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
1183 my ($from, $to) = @_;
1185 return sprintf "BEGIN {\$^H &= ~0xFF; \$^H |= %x}\n", $bits;
1188 sub pp_dbstate { pp_nextstate(@_) }
1189 sub pp_setstate { pp_nextstate(@_) }
1191 sub pp_unstack { return "" } # see also leaveloop
1195 my($op, $cx, $name) = @_;
1199 sub pp_stub { baseop(@_, "()") }
1200 sub pp_wantarray { baseop(@_, "wantarray") }
1201 sub pp_fork { baseop(@_, "fork") }
1202 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1203 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1204 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1205 sub pp_tms { baseop(@_, "times") }
1206 sub pp_ghostent { baseop(@_, "gethostent") }
1207 sub pp_gnetent { baseop(@_, "getnetent") }
1208 sub pp_gprotoent { baseop(@_, "getprotoent") }
1209 sub pp_gservent { baseop(@_, "getservent") }
1210 sub pp_ehostent { baseop(@_, "endhostent") }
1211 sub pp_enetent { baseop(@_, "endnetent") }
1212 sub pp_eprotoent { baseop(@_, "endprotoent") }
1213 sub pp_eservent { baseop(@_, "endservent") }
1214 sub pp_gpwent { baseop(@_, "getpwent") }
1215 sub pp_spwent { baseop(@_, "setpwent") }
1216 sub pp_epwent { baseop(@_, "endpwent") }
1217 sub pp_ggrent { baseop(@_, "getgrent") }
1218 sub pp_sgrent { baseop(@_, "setgrent") }
1219 sub pp_egrent { baseop(@_, "endgrent") }
1220 sub pp_getlogin { baseop(@_, "getlogin") }
1222 sub POSTFIX () { 1 }
1224 # I couldn't think of a good short name, but this is the category of
1225 # symbolic unary operators with interesting precedence
1229 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1230 my $kid = $op->first;
1231 $kid = $self->deparse($kid, $prec);
1232 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1236 sub pp_preinc { pfixop(@_, "++", 23) }
1237 sub pp_predec { pfixop(@_, "--", 23) }
1238 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1239 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1240 sub pp_i_preinc { pfixop(@_, "++", 23) }
1241 sub pp_i_predec { pfixop(@_, "--", 23) }
1242 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1243 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1244 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1246 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1250 if ($op->first->name =~ /^(i_)?negate$/) {
1252 $self->pfixop($op, $cx, "-", 21.5);
1254 $self->pfixop($op, $cx, "-", 21);
1257 sub pp_i_negate { pp_negate(@_) }
1263 $self->pfixop($op, $cx, "not ", 4);
1265 $self->pfixop($op, $cx, "!", 21);
1271 my($op, $cx, $name) = @_;
1273 if ($op->flags & OPf_KIDS) {
1275 if (defined prototype("CORE::$name")
1276 && prototype("CORE::$name") =~ /^;?\*/
1277 && $kid->name eq "rv2gv") {
1281 return $self->maybe_parens_unop($name, $kid, $cx);
1283 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1287 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1288 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1289 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1290 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1291 sub pp_defined { unop(@_, "defined") }
1292 sub pp_undef { unop(@_, "undef") }
1293 sub pp_study { unop(@_, "study") }
1294 sub pp_ref { unop(@_, "ref") }
1295 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1297 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1298 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1299 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1300 sub pp_srand { unop(@_, "srand") }
1301 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1302 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1303 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1304 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1305 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1306 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1307 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1309 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1310 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1311 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1313 sub pp_each { unop(@_, "each") }
1314 sub pp_values { unop(@_, "values") }
1315 sub pp_keys { unop(@_, "keys") }
1316 sub pp_pop { unop(@_, "pop") }
1317 sub pp_shift { unop(@_, "shift") }
1319 sub pp_caller { unop(@_, "caller") }
1320 sub pp_reset { unop(@_, "reset") }
1321 sub pp_exit { unop(@_, "exit") }
1322 sub pp_prototype { unop(@_, "prototype") }
1324 sub pp_close { unop(@_, "close") }
1325 sub pp_fileno { unop(@_, "fileno") }
1326 sub pp_umask { unop(@_, "umask") }
1327 sub pp_untie { unop(@_, "untie") }
1328 sub pp_tied { unop(@_, "tied") }
1329 sub pp_dbmclose { unop(@_, "dbmclose") }
1330 sub pp_getc { unop(@_, "getc") }
1331 sub pp_eof { unop(@_, "eof") }
1332 sub pp_tell { unop(@_, "tell") }
1333 sub pp_getsockname { unop(@_, "getsockname") }
1334 sub pp_getpeername { unop(@_, "getpeername") }
1336 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1337 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1338 sub pp_readlink { unop(@_, "readlink") }
1339 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1340 sub pp_readdir { unop(@_, "readdir") }
1341 sub pp_telldir { unop(@_, "telldir") }
1342 sub pp_rewinddir { unop(@_, "rewinddir") }
1343 sub pp_closedir { unop(@_, "closedir") }
1344 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1345 sub pp_localtime { unop(@_, "localtime") }
1346 sub pp_gmtime { unop(@_, "gmtime") }
1347 sub pp_alarm { unop(@_, "alarm") }
1348 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1350 sub pp_dofile { unop(@_, "do") }
1351 sub pp_entereval { unop(@_, "eval") }
1353 sub pp_ghbyname { unop(@_, "gethostbyname") }
1354 sub pp_gnbyname { unop(@_, "getnetbyname") }
1355 sub pp_gpbyname { unop(@_, "getprotobyname") }
1356 sub pp_shostent { unop(@_, "sethostent") }
1357 sub pp_snetent { unop(@_, "setnetent") }
1358 sub pp_sprotoent { unop(@_, "setprotoent") }
1359 sub pp_sservent { unop(@_, "setservent") }
1360 sub pp_gpwnam { unop(@_, "getpwnam") }
1361 sub pp_gpwuid { unop(@_, "getpwuid") }
1362 sub pp_ggrnam { unop(@_, "getgrnam") }
1363 sub pp_ggrgid { unop(@_, "getgrgid") }
1365 sub pp_lock { unop(@_, "lock") }
1371 if ($op->private & OPpEXISTS_SUB) {
1372 # Checking for the existence of a subroutine
1373 return $self->maybe_parens_func("exists",
1374 $self->pp_rv2cv($op->first, 16), $cx, 16);
1376 if ($op->flags & OPf_SPECIAL) {
1377 # Array element, not hash element
1378 return $self->maybe_parens_func("exists",
1379 $self->pp_aelem($op->first, 16), $cx, 16);
1381 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1389 if ($op->private & OPpSLICE) {
1390 if ($op->flags & OPf_SPECIAL) {
1391 # Deleting from an array, not a hash
1392 return $self->maybe_parens_func("delete",
1393 $self->pp_aslice($op->first, 16),
1396 return $self->maybe_parens_func("delete",
1397 $self->pp_hslice($op->first, 16),
1400 if ($op->flags & OPf_SPECIAL) {
1401 # Deleting from an array, not a hash
1402 return $self->maybe_parens_func("delete",
1403 $self->pp_aelem($op->first, 16),
1406 return $self->maybe_parens_func("delete",
1407 $self->pp_helem($op->first, 16),
1415 if (class($op) eq "UNOP" and $op->first->name eq "const"
1416 and $op->first->private & OPpCONST_BARE)
1418 my $name = $self->const_sv($op->first)->PV;
1421 return "require $name";
1423 $self->unop($op, $cx, "require");
1430 my $kid = $op->first;
1431 if (not null $kid->sibling) {
1432 # XXX Was a here-doc
1433 return $self->dquote($op);
1435 $self->unop(@_, "scalar");
1442 #cluck "curcv was undef" unless $self->{curcv};
1443 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1449 my $kid = $op->first;
1450 if ($kid->name eq "null") {
1452 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1453 my($pre, $post) = @{{"anonlist" => ["[","]"],
1454 "anonhash" => ["{","}"]}->{$kid->name}};
1456 $kid = $kid->first->sibling; # skip pushmark
1457 for (; !null($kid); $kid = $kid->sibling) {
1458 $expr = $self->deparse($kid, 6);
1461 return $pre . join(", ", @exprs) . $post;
1462 } elsif (!null($kid->sibling) and
1463 $kid->sibling->name eq "anoncode") {
1465 $self->deparse_sub($self->padval($kid->sibling->targ));
1466 } elsif ($kid->name eq "pushmark") {
1467 my $sib_name = $kid->sibling->name;
1468 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1469 and not $kid->sibling->flags & OPf_REF)
1471 # The @a in \(@a) isn't in ref context, but only when the
1473 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1474 } elsif ($sib_name eq 'entersub') {
1475 my $text = $self->deparse($kid->sibling, 1);
1476 # Always show parens for \(&func()), but only with -p otherwise
1477 $text = "($text)" if $self->{'parens'}
1478 or $kid->sibling->private & OPpENTERSUB_AMPER;
1483 $self->pfixop($op, $cx, "\\", 20);
1486 sub pp_srefgen { pp_refgen(@_) }
1491 my $kid = $op->first;
1492 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1493 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1494 return $self->unop($op, $cx, "readline");
1497 # Unary operators that can occur as pseudo-listops inside double quotes
1500 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1502 if ($op->flags & OPf_KIDS) {
1504 # If there's more than one kid, the first is an ex-pushmark.
1505 $kid = $kid->sibling if not null $kid->sibling;
1506 return $self->maybe_parens_unop($name, $kid, $cx);
1508 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1512 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1513 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1514 sub pp_uc { dq_unop(@_, "uc") }
1515 sub pp_lc { dq_unop(@_, "lc") }
1516 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1520 my ($op, $cx, $name) = @_;
1521 if (class($op) eq "PVOP") {
1522 return "$name " . $op->pv;
1523 } elsif (class($op) eq "OP") {
1525 } elsif (class($op) eq "UNOP") {
1526 # Note -- loop exits are actually exempt from the
1527 # looks-like-a-func rule, but a few extra parens won't hurt
1528 return $self->maybe_parens_unop($name, $op->first, $cx);
1532 sub pp_last { loopex(@_, "last") }
1533 sub pp_next { loopex(@_, "next") }
1534 sub pp_redo { loopex(@_, "redo") }
1535 sub pp_goto { loopex(@_, "goto") }
1536 sub pp_dump { loopex(@_, "dump") }
1540 my($op, $cx, $name) = @_;
1541 if (class($op) eq "UNOP") {
1542 # Genuine `-X' filetests are exempt from the LLAFR, but not
1543 # l?stat(); for the sake of clarity, give'em all parens
1544 return $self->maybe_parens_unop($name, $op->first, $cx);
1545 } elsif (class($op) eq "SVOP") {
1546 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1547 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1552 sub pp_lstat { ftst(@_, "lstat") }
1553 sub pp_stat { ftst(@_, "stat") }
1554 sub pp_ftrread { ftst(@_, "-R") }
1555 sub pp_ftrwrite { ftst(@_, "-W") }
1556 sub pp_ftrexec { ftst(@_, "-X") }
1557 sub pp_fteread { ftst(@_, "-r") }
1558 sub pp_ftewrite { ftst(@_, "-w") }
1559 sub pp_fteexec { ftst(@_, "-x") }
1560 sub pp_ftis { ftst(@_, "-e") }
1561 sub pp_fteowned { ftst(@_, "-O") }
1562 sub pp_ftrowned { ftst(@_, "-o") }
1563 sub pp_ftzero { ftst(@_, "-z") }
1564 sub pp_ftsize { ftst(@_, "-s") }
1565 sub pp_ftmtime { ftst(@_, "-M") }
1566 sub pp_ftatime { ftst(@_, "-A") }
1567 sub pp_ftctime { ftst(@_, "-C") }
1568 sub pp_ftsock { ftst(@_, "-S") }
1569 sub pp_ftchr { ftst(@_, "-c") }
1570 sub pp_ftblk { ftst(@_, "-b") }
1571 sub pp_ftfile { ftst(@_, "-f") }
1572 sub pp_ftdir { ftst(@_, "-d") }
1573 sub pp_ftpipe { ftst(@_, "-p") }
1574 sub pp_ftlink { ftst(@_, "-l") }
1575 sub pp_ftsuid { ftst(@_, "-u") }
1576 sub pp_ftsgid { ftst(@_, "-g") }
1577 sub pp_ftsvtx { ftst(@_, "-k") }
1578 sub pp_fttty { ftst(@_, "-t") }
1579 sub pp_fttext { ftst(@_, "-T") }
1580 sub pp_ftbinary { ftst(@_, "-B") }
1582 sub SWAP_CHILDREN () { 1 }
1583 sub ASSIGN () { 2 } # has OP= variant
1589 my $name = $op->name;
1590 if ($name eq "concat" and $op->first->name eq "concat") {
1591 # avoid spurious `=' -- see comment in pp_concat
1594 if ($name eq "null" and class($op) eq "UNOP"
1595 and $op->first->name =~ /^(and|x?or)$/
1596 and null $op->first->sibling)
1598 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1599 # with a null that's used as the common end point of the two
1600 # flows of control. For precedence purposes, ignore it.
1601 # (COND_EXPRs have these too, but we don't bother with
1602 # their associativity).
1603 return assoc_class($op->first);
1605 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1608 # Left associative operators, like `+', for which
1609 # $a + $b + $c is equivalent to ($a + $b) + $c
1612 %left = ('multiply' => 19, 'i_multiply' => 19,
1613 'divide' => 19, 'i_divide' => 19,
1614 'modulo' => 19, 'i_modulo' => 19,
1616 'add' => 18, 'i_add' => 18,
1617 'subtract' => 18, 'i_subtract' => 18,
1619 'left_shift' => 17, 'right_shift' => 17,
1621 'bit_or' => 12, 'bit_xor' => 12,
1623 'or' => 2, 'xor' => 2,
1627 sub deparse_binop_left {
1629 my($op, $left, $prec) = @_;
1630 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1631 and $left{assoc_class($op)} == $left{assoc_class($left)})
1633 return $self->deparse($left, $prec - .00001);
1635 return $self->deparse($left, $prec);
1639 # Right associative operators, like `=', for which
1640 # $a = $b = $c is equivalent to $a = ($b = $c)
1643 %right = ('pow' => 22,
1644 'sassign=' => 7, 'aassign=' => 7,
1645 'multiply=' => 7, 'i_multiply=' => 7,
1646 'divide=' => 7, 'i_divide=' => 7,
1647 'modulo=' => 7, 'i_modulo=' => 7,
1649 'add=' => 7, 'i_add=' => 7,
1650 'subtract=' => 7, 'i_subtract=' => 7,
1652 'left_shift=' => 7, 'right_shift=' => 7,
1654 'bit_or=' => 7, 'bit_xor=' => 7,
1660 sub deparse_binop_right {
1662 my($op, $right, $prec) = @_;
1663 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1664 and $right{assoc_class($op)} == $right{assoc_class($right)})
1666 return $self->deparse($right, $prec - .00001);
1668 return $self->deparse($right, $prec);
1674 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1675 my $left = $op->first;
1676 my $right = $op->last;
1678 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1682 if ($flags & SWAP_CHILDREN) {
1683 ($left, $right) = ($right, $left);
1685 $left = $self->deparse_binop_left($op, $left, $prec);
1686 $right = $self->deparse_binop_right($op, $right, $prec);
1687 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1690 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1691 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1692 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1693 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1694 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1695 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1696 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1697 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1698 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1699 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1700 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1702 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1703 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1704 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1705 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1706 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1708 sub pp_eq { binop(@_, "==", 14) }
1709 sub pp_ne { binop(@_, "!=", 14) }
1710 sub pp_lt { binop(@_, "<", 15) }
1711 sub pp_gt { binop(@_, ">", 15) }
1712 sub pp_ge { binop(@_, ">=", 15) }
1713 sub pp_le { binop(@_, "<=", 15) }
1714 sub pp_ncmp { binop(@_, "<=>", 14) }
1715 sub pp_i_eq { binop(@_, "==", 14) }
1716 sub pp_i_ne { binop(@_, "!=", 14) }
1717 sub pp_i_lt { binop(@_, "<", 15) }
1718 sub pp_i_gt { binop(@_, ">", 15) }
1719 sub pp_i_ge { binop(@_, ">=", 15) }
1720 sub pp_i_le { binop(@_, "<=", 15) }
1721 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1723 sub pp_seq { binop(@_, "eq", 14) }
1724 sub pp_sne { binop(@_, "ne", 14) }
1725 sub pp_slt { binop(@_, "lt", 15) }
1726 sub pp_sgt { binop(@_, "gt", 15) }
1727 sub pp_sge { binop(@_, "ge", 15) }
1728 sub pp_sle { binop(@_, "le", 15) }
1729 sub pp_scmp { binop(@_, "cmp", 14) }
1731 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1732 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1734 # `.' is special because concats-of-concats are optimized to save copying
1735 # by making all but the first concat stacked. The effect is as if the
1736 # programmer had written `($a . $b) .= $c', except legal.
1737 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1741 my $left = $op->first;
1742 my $right = $op->last;
1745 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1749 $left = $self->deparse_binop_left($op, $left, $prec);
1750 $right = $self->deparse_binop_right($op, $right, $prec);
1751 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1754 # `x' is weird when the left arg is a list
1758 my $left = $op->first;
1759 my $right = $op->last;
1762 if ($op->flags & OPf_STACKED) {
1766 if (null($right)) { # list repeat; count is inside left-side ex-list
1767 my $kid = $left->first->sibling; # skip pushmark
1769 for (; !null($kid->sibling); $kid = $kid->sibling) {
1770 push @exprs, $self->deparse($kid, 6);
1773 $left = "(" . join(", ", @exprs). ")";
1775 $left = $self->deparse_binop_left($op, $left, $prec);
1777 $right = $self->deparse_binop_right($op, $right, $prec);
1778 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1783 my ($op, $cx, $type) = @_;
1784 my $left = $op->first;
1785 my $right = $left->sibling;
1786 $left = $self->deparse($left, 9);
1787 $right = $self->deparse($right, 9);
1788 return $self->maybe_parens("$left $type $right", $cx, 9);
1794 my $flip = $op->first;
1795 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1796 return $self->range($flip->first, $cx, $type);
1799 # one-line while/until is handled in pp_leave
1803 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1804 my $left = $op->first;
1805 my $right = $op->first->sibling;
1806 if ($cx == 0 and is_scope($right) and $blockname
1807 and $self->{'expand'} < 7)
1809 $left = $self->deparse($left, 1);
1810 $right = $self->deparse($right, 0);
1811 return "$blockname ($left) {\n\t$right\n\b}\cK";
1812 } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1813 and $self->{'expand'} < 7) { # $b if $a
1814 $right = $self->deparse($right, 1);
1815 $left = $self->deparse($left, 1);
1816 return "$right $blockname $left";
1817 } elsif ($cx > $lowprec and $highop) { # $a && $b
1818 $left = $self->deparse_binop_left($op, $left, $highprec);
1819 $right = $self->deparse_binop_right($op, $right, $highprec);
1820 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1821 } else { # $a and $b
1822 $left = $self->deparse_binop_left($op, $left, $lowprec);
1823 $right = $self->deparse_binop_right($op, $right, $lowprec);
1824 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1828 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1829 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1831 # xor is syntactically a logop, but it's really a binop (contrary to
1832 # old versions of opcode.pl). Syntax is what matters here.
1833 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1837 my ($op, $cx, $opname) = @_;
1838 my $left = $op->first;
1839 my $right = $op->first->sibling->first; # skip sassign
1840 $left = $self->deparse($left, 7);
1841 $right = $self->deparse($right, 7);
1842 return $self->maybe_parens("$left $opname $right", $cx, 7);
1845 sub pp_andassign { logassignop(@_, "&&=") }
1846 sub pp_orassign { logassignop(@_, "||=") }
1850 my($op, $cx, $name) = @_;
1852 my $parens = ($cx >= 5) || $self->{'parens'};
1853 my $kid = $op->first->sibling;
1854 return $name if null $kid;
1856 if (defined prototype("CORE::$name")
1857 && prototype("CORE::$name") =~ /^;?\*/
1858 && $kid->name eq "rv2gv") {
1859 $first = $self->deparse($kid->first, 6);
1862 $first = $self->deparse($kid, 6);
1864 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1865 push @exprs, $first;
1866 $kid = $kid->sibling;
1867 for (; !null($kid); $kid = $kid->sibling) {
1868 push @exprs, $self->deparse($kid, 6);
1871 return "$name(" . join(", ", @exprs) . ")";
1873 return "$name " . join(", ", @exprs);
1877 sub pp_bless { listop(@_, "bless") }
1878 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1879 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1880 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1881 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1882 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1883 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1884 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1885 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1886 sub pp_unpack { listop(@_, "unpack") }
1887 sub pp_pack { listop(@_, "pack") }
1888 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1889 sub pp_splice { listop(@_, "splice") }
1890 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1891 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1892 sub pp_reverse { listop(@_, "reverse") }
1893 sub pp_warn { listop(@_, "warn") }
1894 sub pp_die { listop(@_, "die") }
1895 # Actually, return is exempt from the LLAFR (see examples in this very
1896 # module!), but for consistency's sake, ignore that fact
1897 sub pp_return { listop(@_, "return") }
1898 sub pp_open { listop(@_, "open") }
1899 sub pp_pipe_op { listop(@_, "pipe") }
1900 sub pp_tie { listop(@_, "tie") }
1901 sub pp_binmode { listop(@_, "binmode") }
1902 sub pp_dbmopen { listop(@_, "dbmopen") }
1903 sub pp_sselect { listop(@_, "select") }
1904 sub pp_select { listop(@_, "select") }
1905 sub pp_read { listop(@_, "read") }
1906 sub pp_sysopen { listop(@_, "sysopen") }
1907 sub pp_sysseek { listop(@_, "sysseek") }
1908 sub pp_sysread { listop(@_, "sysread") }
1909 sub pp_syswrite { listop(@_, "syswrite") }
1910 sub pp_send { listop(@_, "send") }
1911 sub pp_recv { listop(@_, "recv") }
1912 sub pp_seek { listop(@_, "seek") }
1913 sub pp_fcntl { listop(@_, "fcntl") }
1914 sub pp_ioctl { listop(@_, "ioctl") }
1915 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1916 sub pp_socket { listop(@_, "socket") }
1917 sub pp_sockpair { listop(@_, "sockpair") }
1918 sub pp_bind { listop(@_, "bind") }
1919 sub pp_connect { listop(@_, "connect") }
1920 sub pp_listen { listop(@_, "listen") }
1921 sub pp_accept { listop(@_, "accept") }
1922 sub pp_shutdown { listop(@_, "shutdown") }
1923 sub pp_gsockopt { listop(@_, "getsockopt") }
1924 sub pp_ssockopt { listop(@_, "setsockopt") }
1925 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1926 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1927 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1928 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1929 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1930 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1931 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1932 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1933 sub pp_open_dir { listop(@_, "opendir") }
1934 sub pp_seekdir { listop(@_, "seekdir") }
1935 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1936 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1937 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1938 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1939 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1940 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1941 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1942 sub pp_shmget { listop(@_, "shmget") }
1943 sub pp_shmctl { listop(@_, "shmctl") }
1944 sub pp_shmread { listop(@_, "shmread") }
1945 sub pp_shmwrite { listop(@_, "shmwrite") }
1946 sub pp_msgget { listop(@_, "msgget") }
1947 sub pp_msgctl { listop(@_, "msgctl") }
1948 sub pp_msgsnd { listop(@_, "msgsnd") }
1949 sub pp_msgrcv { listop(@_, "msgrcv") }
1950 sub pp_semget { listop(@_, "semget") }
1951 sub pp_semctl { listop(@_, "semctl") }
1952 sub pp_semop { listop(@_, "semop") }
1953 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1954 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1955 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1956 sub pp_gsbyname { listop(@_, "getservbyname") }
1957 sub pp_gsbyport { listop(@_, "getservbyport") }
1958 sub pp_syscall { listop(@_, "syscall") }
1963 my $text = $self->dq($op->first->sibling); # skip pushmark
1964 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1965 or $text =~ /[<>]/) {
1966 return 'glob(' . single_delim('qq', '"', $text) . ')';
1968 return '<' . $text . '>';
1972 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1973 # be a filehandle. This could probably be better fixed in the core
1974 # by moving the GV lookup into ck_truc.
1980 my $parens = ($cx >= 5) || $self->{'parens'};
1981 my $kid = $op->first->sibling;
1983 if ($op->flags & OPf_SPECIAL) {
1984 # $kid is an OP_CONST
1985 $fh = $self->const_sv($kid)->PV;
1987 $fh = $self->deparse($kid, 6);
1988 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1990 my $len = $self->deparse($kid->sibling, 6);
1992 return "truncate($fh, $len)";
1994 return "truncate $fh, $len";
2000 my($op, $cx, $name) = @_;
2002 my $kid = $op->first->sibling;
2004 if ($op->flags & OPf_STACKED) {
2006 $indir = $indir->first; # skip rv2gv
2007 if (is_scope($indir)) {
2008 $indir = "{" . $self->deparse($indir, 0) . "}";
2010 $indir = $self->deparse($indir, 24);
2012 $indir = $indir . " ";
2013 $kid = $kid->sibling;
2015 for (; !null($kid); $kid = $kid->sibling) {
2016 $expr = $self->deparse($kid, 6);
2019 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
2023 sub pp_prtf { indirop(@_, "printf") }
2024 sub pp_print { indirop(@_, "print") }
2025 sub pp_sort { indirop(@_, "sort") }
2029 my($op, $cx, $name) = @_;
2031 my $kid = $op->first; # this is the (map|grep)start
2032 $kid = $kid->first->sibling; # skip a pushmark
2033 my $code = $kid->first; # skip a null
2034 if (is_scope $code) {
2035 $code = "{" . $self->deparse($code, 0) . "} ";
2037 $code = $self->deparse($code, 24) . ", ";
2039 $kid = $kid->sibling;
2040 for (; !null($kid); $kid = $kid->sibling) {
2041 $expr = $self->deparse($kid, 6);
2042 push @exprs, $expr if $expr;
2044 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2047 sub pp_mapwhile { mapop(@_, "map") }
2048 sub pp_grepwhile { mapop(@_, "grep") }
2054 my $kid = $op->first->sibling; # skip pushmark
2056 my $local = "either"; # could be local(...) or my(...)
2057 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2058 # This assumes that no other private flags equal 128, and that
2059 # OPs that store things other than flags in their op_private,
2060 # like OP_AELEMFAST, won't be immediate children of a list.
2061 unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
2063 $local = ""; # or not
2066 if ($lop->name =~ /^pad[ash]v$/) { # my()
2067 ($local = "", last) if $local eq "local";
2069 } elsif ($lop->name ne "undef") { # local()
2070 ($local = "", last) if $local eq "my";
2074 $local = "" if $local eq "either"; # no point if it's all undefs
2075 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2076 for (; !null($kid); $kid = $kid->sibling) {
2078 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2083 $self->{'avoid_local'}{$$lop}++;
2084 $expr = $self->deparse($kid, 6);
2085 delete $self->{'avoid_local'}{$$lop};
2087 $expr = $self->deparse($kid, 6);
2092 return "$local(" . join(", ", @exprs) . ")";
2094 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2098 sub is_ifelse_cont {
2100 return ($op->name eq "null" and class($op) eq "UNOP"
2101 and $op->first->name =~ /^(and|cond_expr)$/
2102 and is_scope($op->first->first->sibling));
2108 my $cond = $op->first;
2109 my $true = $cond->sibling;
2110 my $false = $true->sibling;
2111 my $cuddle = $self->{'cuddle'};
2112 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
2113 (is_scope($false) || is_ifelse_cont($false))
2114 and $self->{'expand'} < 7) {
2115 $cond = $self->deparse($cond, 8);
2116 $true = $self->deparse($true, 8);
2117 $false = $self->deparse($false, 8);
2118 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2121 $cond = $self->deparse($cond, 1);
2122 $true = $self->deparse($true, 0);
2123 my $head = "if ($cond) {\n\t$true\n\b}";
2125 while (!null($false) and is_ifelse_cont($false)) {
2126 my $newop = $false->first;
2127 my $newcond = $newop->first;
2128 my $newtrue = $newcond->sibling;
2129 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2130 $newcond = $self->deparse($newcond, 1);
2131 $newtrue = $self->deparse($newtrue, 0);
2132 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2134 if (!null($false)) {
2135 $false = $cuddle . "else {\n\t" .
2136 $self->deparse($false, 0) . "\n\b}\cK";
2140 return $head . join($cuddle, "", @elsifs) . $false;
2145 my($op, $cx, $init) = @_;
2146 my $enter = $op->first;
2147 my $kid = $enter->sibling;
2148 local(@$self{qw'curstash warnings hints'})
2149 = @$self{qw'curstash warnings hints'};
2154 my $out_seq = $self->{'curcop'}->cop_seq;;
2155 if ($kid->name eq "lineseq") { # bare or infinite loop
2156 if (is_state $kid->last) { # infinite
2157 $head = "for (;;) "; # shorter than while (1)
2163 } elsif ($enter->name eq "enteriter") { # foreach
2164 my $ary = $enter->first->sibling; # first was pushmark
2165 my $var = $ary->sibling;
2166 if ($enter->flags & OPf_STACKED
2167 and not null $ary->first->sibling->sibling)
2169 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2170 $self->deparse($ary->first->sibling->sibling, 9);
2172 $ary = $self->deparse($ary, 1);
2175 if ($enter->flags & OPf_SPECIAL) { # thread special var
2176 $var = $self->pp_threadsv($enter, 1);
2177 } else { # regular my() variable
2178 $var = $self->pp_padsv($enter, 1);
2179 if ($self->padname_sv($enter->targ)->IVX ==
2180 $kid->first->first->sibling->last->cop_seq)
2182 # If the scope of this variable closes at the last
2183 # statement of the loop, it must have been
2185 $var = "my " . $var;
2188 } elsif ($var->name eq "rv2gv") {
2189 $var = $self->pp_rv2sv($var, 1);
2190 } elsif ($var->name eq "gv") {
2191 $var = "\$" . $self->deparse($var, 1);
2193 $head = "foreach $var ($ary) ";
2194 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2195 } elsif ($kid->name eq "null") { # while/until
2197 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2198 $cond = $self->deparse($kid->first, 1);
2199 $head = "$name ($cond) ";
2200 $body = $kid->first->sibling;
2201 } elsif ($kid->name eq "stub") { # bare and empty
2202 return "{;}"; # {} could be a hashref
2204 # If there isn't a continue block, then the next pointer for the loop
2205 # will point to the unstack, which is kid's penultimate child, except
2206 # in a bare loop, when it will point to the leaveloop. When neither of
2207 # these conditions hold, then the third-to-last child in the continue
2208 # block (or the last in a bare loop).
2209 my $cont_start = $enter->nextop;
2211 if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
2213 $cont = $body->last;
2215 $cont = $body->first;
2216 while (!null($cont->sibling->sibling->sibling)) {
2217 $cont = $cont->sibling;
2220 my $state = $body->first;
2221 my $cuddle = $self->{'cuddle'};
2223 for (; $$state != $$cont; $state = $state->sibling) {
2224 push @states, $state;
2226 $body = $self->lineseq(@states);
2227 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2228 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2231 $cont = $cuddle . "continue {\n\t" .
2232 $self->deparse($cont, 0) . "\n\b}\cK";
2235 return "" if !defined $body;
2237 $body = $self->deparse($body, 0);
2240 # If we have say C<{my $x=2; sub x{$x}}>, the sub must go inside
2241 # the loop. So we insert any subs which are due here.
2242 $body .= join"", $self->seq_subs($out_seq);
2244 return $head . "{\n\t" . $body . "\b}" . $cont;
2247 sub pp_leaveloop { loop_common(@_, "") }
2252 my $init = $self->deparse($op, 1);
2253 return $self->loop_common($op->sibling, $cx, $init);
2258 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2261 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2262 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2267 if (class($op) eq "OP") {
2269 return $self->{'ex_const'} if $op->targ == OP_CONST;
2270 } elsif ($op->first->name eq "pushmark") {
2271 return $self->pp_list($op, $cx);
2272 } elsif ($op->first->name eq "enter") {
2273 return $self->pp_leave($op, $cx);
2274 } elsif ($op->targ == OP_STRINGIFY) {
2275 return $self->dquote($op, $cx);
2276 } elsif (!null($op->first->sibling) and
2277 $op->first->sibling->name eq "readline" and
2278 $op->first->sibling->flags & OPf_STACKED) {
2279 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2280 . $self->deparse($op->first->sibling, 7),
2282 } elsif (!null($op->first->sibling) and
2283 $op->first->sibling->name eq "trans" and
2284 $op->first->sibling->flags & OPf_STACKED) {
2285 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2286 . $self->deparse($op->first->sibling, 20),
2289 return $self->deparse($op->first, $cx);
2296 return $self->padname_sv($targ)->PVX;
2302 return substr($self->padname($op->targ), 1); # skip $/@/%
2308 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2311 sub pp_padav { pp_padsv(@_) }
2312 sub pp_padhv { pp_padsv(@_) }
2317 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2318 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2319 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2326 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2332 if (class($op) eq "PADOP") {
2333 return $self->padval($op->padix);
2334 } else { # class($op) eq "SVOP"
2342 my $gv = $self->gv_or_padgv($op);
2343 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2344 $self->gv_name($gv)));
2350 my $gv = $self->gv_or_padgv($op);
2351 return $self->gv_name($gv);
2357 my $gv = $self->gv_or_padgv($op);
2358 return "\$" . $self->gv_name($gv) . "[" .
2359 ($op->private + $self->{'arybase'}) . "]";
2364 my($op, $cx, $type) = @_;
2365 my $kid = $op->first;
2366 my $str = $self->deparse($kid, 0);
2367 return $self->stash_variable($type, $str) if is_scalar($kid);
2368 return $type ."{$str}";
2371 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2372 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2373 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2379 if ($op->first->name eq "padav") {
2380 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2382 return $self->maybe_local($op, $cx,
2383 $self->rv2x($op->first, $cx, '$#'));
2387 # skip down to the old, ex-rv2cv
2388 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
2393 my $kid = $op->first;
2394 if ($kid->name eq "const") { # constant list
2395 my $av = $self->const_sv($kid);
2396 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2398 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2402 sub is_subscriptable {
2404 if ($op->name =~ /^[ahg]elem/) {
2406 } elsif ($op->name eq "entersub") {
2407 my $kid = $op->first;
2408 return 0 unless null $kid->sibling;
2410 $kid = $kid->sibling until null $kid->sibling;
2411 return 0 if is_scope($kid);
2413 return 0 if $kid->name eq "gv";
2414 return 0 if is_scalar($kid);
2415 return is_subscriptable($kid);
2423 my ($op, $cx, $left, $right, $padname) = @_;
2424 my($array, $idx) = ($op->first, $op->first->sibling);
2425 unless ($array->name eq $padname) { # Maybe this has been fixed
2426 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2428 if ($array->name eq $padname) {
2429 $array = $self->padany($array);
2430 } elsif (is_scope($array)) { # ${expr}[0]
2431 $array = "{" . $self->deparse($array, 0) . "}";
2432 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2433 $array = $self->deparse($array, 24);
2435 # $x[20][3]{hi} or expr->[20]
2436 my $arrow = is_subscriptable($array) ? "" : "->";
2437 return $self->deparse($array, 24) . $arrow .
2438 $left . $self->deparse($idx, 1) . $right;
2440 $idx = $self->deparse($idx, 1);
2442 # Outer parens in an array index will confuse perl
2443 # if we're interpolating in a regular expression, i.e.
2444 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2446 # If $self->{parens}, then an initial '(' will
2447 # definitely be paired with a final ')'. If
2448 # !$self->{parens}, the misleading parens won't
2449 # have been added in the first place.
2451 # [You might think that we could get "(...)...(...)"
2452 # where the initial and final parens do not match
2453 # each other. But we can't, because the above would
2454 # only happen if there's an infix binop between the
2455 # two pairs of parens, and *that* means that the whole
2456 # expression would be parenthesized as well.]
2458 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2460 return "\$" . $array . $left . $idx . $right;
2463 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2464 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2469 my($glob, $part) = ($op->first, $op->last);
2470 $glob = $glob->first; # skip rv2gv
2471 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2472 my $scope = is_scope($glob);
2473 $glob = $self->deparse($glob, 0);
2474 $part = $self->deparse($part, 1);
2475 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2480 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2482 my(@elems, $kid, $array, $list);
2483 if (class($op) eq "LISTOP") {
2485 } else { # ex-hslice inside delete()
2486 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2490 $array = $array->first
2491 if $array->name eq $regname or $array->name eq "null";
2492 if (is_scope($array)) {
2493 $array = "{" . $self->deparse($array, 0) . "}";
2494 } elsif ($array->name eq $padname) {
2495 $array = $self->padany($array);
2497 $array = $self->deparse($array, 24);
2499 $kid = $op->first->sibling; # skip pushmark
2500 if ($kid->name eq "list") {
2501 $kid = $kid->first->sibling; # skip list, pushmark
2502 for (; !null $kid; $kid = $kid->sibling) {
2503 push @elems, $self->deparse($kid, 6);
2505 $list = join(", ", @elems);
2507 $list = $self->deparse($kid, 1);
2509 return "\@" . $array . $left . $list . $right;
2512 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2513 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2518 my $idx = $op->first;
2519 my $list = $op->last;
2521 $list = $self->deparse($list, 1);
2522 $idx = $self->deparse($idx, 1);
2523 return "($list)" . "[$idx]";
2528 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2533 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2539 my $kid = $op->first->sibling; # skip pushmark
2540 my($meth, $obj, @exprs);
2541 if ($kid->name eq "list" and want_list $kid) {
2542 # When an indirect object isn't a bareword but the args are in
2543 # parens, the parens aren't part of the method syntax (the LLAFR
2544 # doesn't apply), but they make a list with OPf_PARENS set that
2545 # doesn't get flattened by the append_elem that adds the method,
2546 # making a (object, arg1, arg2, ...) list where the object
2547 # usually is. This can be distinguished from
2548 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2549 # object) because in the later the list is in scalar context
2550 # as the left side of -> always is, while in the former
2551 # the list is in list context as method arguments always are.
2552 # (Good thing there aren't method prototypes!)
2553 $meth = $kid->sibling;
2554 $kid = $kid->first->sibling; # skip pushmark
2556 $kid = $kid->sibling;
2557 for (; not null $kid; $kid = $kid->sibling) {
2558 push @exprs, $self->deparse($kid, 6);
2562 $kid = $kid->sibling;
2563 for (; not null $kid->sibling; $kid = $kid->sibling) {
2564 push @exprs, $self->deparse($kid, 6);
2568 $obj = $self->deparse($obj, 24);
2569 if ($meth->name eq "method_named") {
2570 $meth = $self->const_sv($meth)->PV;
2572 $meth = $meth->first;
2573 if ($meth->name eq "const") {
2574 # As of 5.005_58, this case is probably obsoleted by the
2575 # method_named case above
2576 $meth = $self->const_sv($meth)->PV; # needs to be bare
2578 $meth = $self->deparse($meth, 1);
2581 my $args = join(", ", @exprs);
2582 $kid = $obj . "->" . $meth;
2584 return $kid . "(" . $args . ")"; # parens mandatory
2590 # returns "&" if the prototype doesn't match the args,
2591 # or ("", $args_after_prototype_demunging) if it does.
2594 my($proto, @args) = @_;
2598 # An unbackslashed @ or % gobbles up the rest of the args
2599 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2601 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2604 return "&" if @args;
2605 } elsif ($chr eq ";") {
2607 } elsif ($chr eq "@" or $chr eq "%") {
2608 push @reals, map($self->deparse($_, 6), @args);
2614 if (want_scalar $arg) {
2615 push @reals, $self->deparse($arg, 6);
2619 } elsif ($chr eq "&") {
2620 if ($arg->name =~ /^(s?refgen|undef)$/) {
2621 push @reals, $self->deparse($arg, 6);
2625 } elsif ($chr eq "*") {
2626 if ($arg->name =~ /^s?refgen$/
2627 and $arg->first->first->name eq "rv2gv")
2629 $real = $arg->first->first; # skip refgen, null
2630 if ($real->first->name eq "gv") {
2631 push @reals, $self->deparse($real, 6);
2633 push @reals, $self->deparse($real->first, 6);
2638 } elsif (substr($chr, 0, 1) eq "\\") {
2639 $chr = substr($chr, 1);
2640 if ($arg->name =~ /^s?refgen$/ and
2641 !null($real = $arg->first) and
2642 ($chr eq "\$" && is_scalar($real->first)
2644 && $real->first->sibling->name
2647 && $real->first->sibling->name
2649 #or ($chr eq "&" # This doesn't work
2650 # && $real->first->name eq "rv2cv")
2652 && $real->first->name eq "rv2gv")))
2654 push @reals, $self->deparse($real, 6);
2661 return "&" if $proto and !$doneok; # too few args and no `;'
2662 return "&" if @args; # too many args
2663 return ("", join ", ", @reals);
2669 return $self->method($op, $cx) unless null $op->first->sibling;
2673 if ($op->flags & OPf_SPECIAL) {
2675 } elsif ($op->private & OPpENTERSUB_AMPER) {
2679 $kid = $kid->first->sibling; # skip ex-list, pushmark
2680 for (; not null $kid->sibling; $kid = $kid->sibling) {
2685 if (is_scope($kid)) {
2687 $kid = "{" . $self->deparse($kid, 0) . "}";
2688 } elsif ($kid->first->name eq "gv") {
2689 my $gv = $self->gv_or_padgv($kid->first);
2690 if (class($gv->CV) ne "SPECIAL") {
2691 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2693 $simple = 1; # only calls of named functions can be prototyped
2694 $kid = $self->deparse($kid, 24);
2695 } elsif (is_scalar $kid->first) {
2697 $kid = $self->deparse($kid, 24);
2700 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2701 $kid = $self->deparse($kid, 24) . $arrow;
2704 # Doesn't matter how many prototypes there are, if
2705 # they haven't happened yet!
2706 my $declared = exists $self->{'subs_declared'}{$kid};
2709 if ($declared and defined $proto and not $amper) {
2710 ($amper, $args) = $self->check_proto($proto, @exprs);
2711 if ($amper eq "&") {
2712 $args = join(", ", map($self->deparse($_, 6), @exprs));
2715 $args = join(", ", map($self->deparse($_, 6), @exprs));
2717 if ($prefix or $amper) {
2718 if ($op->flags & OPf_STACKED) {
2719 return $prefix . $amper . $kid . "(" . $args . ")";
2721 return $prefix . $amper. $kid;
2724 # glob() invocations can be translated into calls of
2725 # CORE::GLOBAL::glob with an second parameter, a number.
2727 if ($kid eq "CORE::GLOBAL::glob") {
2729 $args =~ s/\s*,[^,]+$//;
2732 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2733 # so it must have been translated from a keyword call. Translate
2735 $kid =~ s/^CORE::GLOBAL:://;
2738 return "$kid(" . $args . ")";
2739 } elsif (defined $proto and $proto eq "") {
2741 } elsif (defined $proto and $proto eq "\$") {
2742 return $self->maybe_parens_func($kid, $args, $cx, 16);
2743 } elsif (defined($proto) && $proto or $simple) {
2744 return $self->maybe_parens_func($kid, $args, $cx, 5);
2746 return "$kid(" . $args . ")";
2751 sub pp_enterwrite { unop(@_, "write") }
2753 # escape things that cause interpolation in double quotes,
2754 # but not character escapes
2757 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
2761 # the same, but treat $|, $), $( and $ at the end of the string differently
2764 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@](?!\||\)|\$\(|$)|\\[uUlLQE])/$1$2\\$3/g;
2768 # character escapes, but not delimiters that might need to be escaped
2769 sub escape_str { # ASCII, UTF8
2771 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
2773 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2779 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2780 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2784 # Don't do this for regexen
2787 $str =~ s/\\/\\\\/g;
2791 # Remove backslashes which precede literal control characters,
2792 # to avoid creating ambiguity when we escape the latter.
2796 # the insane complexity here is due to the behaviour of "\c\"
2797 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
2801 sub balanced_delim {
2803 my @str = split //, $str;
2804 my($ar, $open, $close, $fail, $c, $cnt);
2805 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2806 ($open, $close) = @$ar;
2807 $fail = 0; $cnt = 0;
2811 } elsif ($c eq $close) {
2820 $fail = 1 if $cnt != 0;
2821 return ($open, "$open$str$close") if not $fail;
2827 my($q, $default, $str) = @_;
2828 return "$default$str$default" if $default and index($str, $default) == -1;
2829 my($succeed, $delim);
2830 ($succeed, $str) = balanced_delim($str);
2831 return "$q$str" if $succeed;
2832 for $delim ('/', '"', '#') {
2833 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2836 $str =~ s/$default/\\$default/g;
2837 return "$default$str$default";
2846 if (class($sv) eq "SPECIAL") {
2847 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2848 } elsif (class($sv) eq "NULL") {
2850 } elsif ($sv->FLAGS & SVf_IOK) {
2851 return $sv->int_value;
2852 } elsif ($sv->FLAGS & SVf_NOK) {
2854 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
2855 return "\\(" . const($sv->RV) . ")"; # constant folded
2858 if ($str =~ /[^ -~]/) { # ASCII for non-printing
2859 return single_delim("qq", '"', uninterp escape_str unback $str);
2861 return single_delim("q", "'", unback $str);
2870 # the constant could be in the pad (under useithreads)
2871 $sv = $self->padval($op->targ) unless $$sv;
2878 if ($op->private & OPpCONST_ARYBASE) {
2881 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2882 # return $self->const_sv($op)->PV;
2884 my $sv = $self->const_sv($op);
2885 # return const($sv);
2887 return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
2893 my $type = $op->name;
2894 if ($type eq "const") {
2895 return '$[' if $op->private & OPpCONST_ARYBASE;
2896 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
2897 } elsif ($type eq "concat") {
2898 my $first = $self->dq($op->first);
2899 my $last = $self->dq($op->last);
2900 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2901 if ($last =~ /^[A-Z\\\^\[\]_?]/) {
2902 $first =~ s/([\$@])\^$/${1}{^}/; # "${^}W" etc
2904 elsif ($last =~ /^[{\[\w]/) {
2905 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2907 return $first . $last;
2908 } elsif ($type eq "uc") {
2909 return '\U' . $self->dq($op->first->sibling) . '\E';
2910 } elsif ($type eq "lc") {
2911 return '\L' . $self->dq($op->first->sibling) . '\E';
2912 } elsif ($type eq "ucfirst") {
2913 return '\u' . $self->dq($op->first->sibling);
2914 } elsif ($type eq "lcfirst") {
2915 return '\l' . $self->dq($op->first->sibling);
2916 } elsif ($type eq "quotemeta") {
2917 return '\Q' . $self->dq($op->first->sibling) . '\E';
2918 } elsif ($type eq "join") {
2919 return $self->deparse($op->last, 26); # was join($", @ary)
2921 return $self->deparse($op, 26);
2929 return single_delim("qx", '`', $self->dq($op->first->sibling));
2935 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2936 return $self->deparse($kid, $cx) if $self->{'unquote'};
2937 $self->maybe_targmy($kid, $cx,
2938 sub {single_delim("qq", '"', $self->dq($_[1]))});
2941 # OP_STRINGIFY is a listop, but it only ever has one arg
2942 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2944 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2945 # note that tr(from)/to/ is OK, but not tr/from/(to)
2947 my($from, $to) = @_;
2948 my($succeed, $delim);
2949 if ($from !~ m[/] and $to !~ m[/]) {
2950 return "/$from/$to/";
2951 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2952 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2955 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2956 return "$from$delim$to$delim" if index($to, $delim) == -1;
2959 return "$from/$to/";
2962 for $delim ('/', '"', '#') { # note no '
2963 return "$delim$from$delim$to$delim"
2964 if index($to . $from, $delim) == -1;
2966 $from =~ s[/][\\/]g;
2968 return "/$from/$to/";
2974 if ($n == ord '\\') {
2976 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2978 } elsif ($n == ord "\a") {
2980 } elsif ($n == ord "\b") {
2982 } elsif ($n == ord "\t") {
2984 } elsif ($n == ord "\n") {
2986 } elsif ($n == ord "\e") {
2988 } elsif ($n == ord "\f") {
2990 } elsif ($n == ord "\r") {
2992 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2993 return '\\c' . chr(ord("@") + $n);
2995 # return '\x' . sprintf("%02x", $n);
2996 return '\\' . sprintf("%03o", $n);
3002 my($str, $c, $tr) = ("");
3003 for ($c = 0; $c < @chars; $c++) {
3006 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3007 $chars[$c + 2] == $tr + 2)
3009 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3012 $str .= pchr($chars[$c]);
3018 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
3021 sub tr_decode_byte {
3022 my($table, $flags) = @_;
3023 my(@table) = unpack("s256", $table);
3024 my($c, $tr, @from, @to, @delfrom, $delhyphen);
3025 if ($table[ord "-"] != -1 and
3026 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3028 $tr = $table[ord "-"];
3029 $table[ord "-"] = -1;
3033 } else { # -2 ==> delete
3037 for ($c = 0; $c < 256; $c++) {
3040 push @from, $c; push @to, $tr;
3041 } elsif ($tr == -2) {
3045 @from = (@from, @delfrom);
3046 if ($flags & OPpTRANS_COMPLEMENT) {
3049 @from{@from} = (1) x @from;
3050 for ($c = 0; $c < 256; $c++) {
3051 push @newfrom, $c unless $from{$c};
3055 unless ($flags & OPpTRANS_DELETE || !@to) {
3056 pop @to while $#to and $to[$#to] == $to[$#to -1];
3059 $from = collapse(@from);
3060 $to = collapse(@to);
3061 $from .= "-" if $delhyphen;
3062 return ($from, $to);
3067 if ($x == ord "-") {
3074 # XXX This doesn't yet handle all cases correctly either
3076 sub tr_decode_utf8 {
3077 my($swash_hv, $flags) = @_;
3078 my %swash = $swash_hv->ARRAY;
3080 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3081 my $none = $swash{"NONE"}->IV;
3082 my $extra = $none + 1;
3083 my(@from, @delfrom, @to);
3085 foreach $line (split /\n/, $swash{'LIST'}->PV) {
3086 my($min, $max, $result) = split(/\t/, $line);
3093 $result = hex $result;
3094 if ($result == $extra) {
3095 push @delfrom, [$min, $max];
3097 push @from, [$min, $max];
3098 push @to, [$result, $result + $max - $min];
3101 for my $i (0 .. $#from) {
3102 if ($from[$i][0] == ord '-') {
3103 unshift @from, splice(@from, $i, 1);
3104 unshift @to, splice(@to, $i, 1);
3106 } elsif ($from[$i][1] == ord '-') {
3109 unshift @from, ord '-';
3110 unshift @to, ord '-';
3114 for my $i (0 .. $#delfrom) {
3115 if ($delfrom[$i][0] == ord '-') {
3116 push @delfrom, splice(@delfrom, $i, 1);
3118 } elsif ($delfrom[$i][1] == ord '-') {
3120 push @delfrom, ord '-';
3124 if (defined $final and $to[$#to][1] != $final) {
3125 push @to, [$final, $final];
3127 push @from, @delfrom;
3128 if ($flags & OPpTRANS_COMPLEMENT) {
3131 for my $i (0 .. $#from) {
3132 push @newfrom, [$next, $from[$i][0] - 1];
3133 $next = $from[$i][1] + 1;
3136 for my $range (@newfrom) {
3137 if ($range->[0] <= $range->[1]) {
3142 my($from, $to, $diff);
3143 for my $chunk (@from) {
3144 $diff = $chunk->[1] - $chunk->[0];
3146 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3147 } elsif ($diff == 1) {
3148 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3150 $from .= tr_chr($chunk->[0]);
3153 for my $chunk (@to) {
3154 $diff = $chunk->[1] - $chunk->[0];
3156 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3157 } elsif ($diff == 1) {
3158 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3160 $to .= tr_chr($chunk->[0]);
3163 #$final = sprintf("%04x", $final) if defined $final;
3164 #$none = sprintf("%04x", $none) if defined $none;
3165 #$extra = sprintf("%04x", $extra) if defined $extra;
3166 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3167 #print STDERR $swash{'LIST'}->PV;
3168 return (escape_str($from), escape_str($to));
3175 if (class($op) eq "PVOP") {
3176 ($from, $to) = tr_decode_byte($op->pv, $op->private);
3177 } else { # class($op) eq "SVOP"
3178 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3181 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3182 $flags .= "d" if $op->private & OPpTRANS_DELETE;
3183 $to = "" if $from eq $to and $flags eq "";
3184 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3185 return "tr" . double_delim($from, $to) . $flags;
3188 # Like dq(), but different
3192 my $type = $op->name;
3193 if ($type eq "const") {
3194 return '$[' if $op->private & OPpCONST_ARYBASE;
3195 return re_uninterp(escape_str(re_unback($self->const_sv($op)->as_string)));
3196 } elsif ($type eq "concat") {
3197 my $first = $self->re_dq($op->first);
3198 my $last = $self->re_dq($op->last);
3199 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3200 if ($last =~ /^[A-Z\\\^\[\]_?]/) {
3201 $first =~ s/([\$@])\^$/${1}{^}/;
3203 elsif ($last =~ /^[{\[\w]/) {
3204 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
3206 return $first . $last;
3207 } elsif ($type eq "uc") {
3208 return '\U' . $self->re_dq($op->first->sibling) . '\E';
3209 } elsif ($type eq "lc") {
3210 return '\L' . $self->re_dq($op->first->sibling) . '\E';
3211 } elsif ($type eq "ucfirst") {
3212 return '\u' . $self->re_dq($op->first->sibling);
3213 } elsif ($type eq "lcfirst") {
3214 return '\l' . $self->re_dq($op->first->sibling);
3215 } elsif ($type eq "quotemeta") {
3216 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
3217 } elsif ($type eq "join") {
3218 return $self->deparse($op->last, 26); # was join($", @ary)
3220 return $self->deparse($op, 26);
3227 my $kid = $op->first;
3228 $kid = $kid->first if $kid->name eq "regcmaybe";
3229 $kid = $kid->first if $kid->name eq "regcreset";
3230 return $self->re_dq($kid);
3233 # osmic acid -- see osmium tetroxide
3236 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3237 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3238 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3242 my($op, $cx, $name, $delim) = @_;
3243 my $kid = $op->first;
3244 my ($binop, $var, $re) = ("", "", "");
3245 if ($op->flags & OPf_STACKED) {
3247 $var = $self->deparse($kid, 20);
3248 $kid = $kid->sibling;
3251 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3253 $re = $self->deparse($kid, 1);
3256 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3257 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3258 $flags .= "i" if $op->pmflags & PMf_FOLD;
3259 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3260 $flags .= "o" if $op->pmflags & PMf_KEEP;
3261 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3262 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3263 $flags = $matchwords{$flags} if $matchwords{$flags};
3264 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3268 $re = single_delim($name, $delim, $re);
3272 return $self->maybe_parens("$var =~ $re", $cx, 20);
3278 sub pp_match { matchop(@_, "m", "/") }
3279 sub pp_pushre { matchop(@_, "m", "/") }
3280 sub pp_qr { matchop(@_, "qr", "") }
3285 my($kid, @exprs, $ary, $expr);
3287 if ($ {$kid->pmreplroot}) {
3288 $ary = '@' . $self->gv_name($kid->pmreplroot);
3290 for (; !null($kid); $kid = $kid->sibling) {
3291 push @exprs, $self->deparse($kid, 6);
3294 # handle special case of split(), and split(" ") that compiles to /\s+/
3296 if ($kid->flags & OPf_SPECIAL
3297 && $exprs[0] eq '/\\s+/'
3298 && $kid->pmflags & PMf_SKIPWHITE ) {
3302 $expr = "split(" . join(", ", @exprs) . ")";
3304 return $self->maybe_parens("$ary = $expr", $cx, 7);
3310 # oxime -- any of various compounds obtained chiefly by the action of
3311 # hydroxylamine on aldehydes and ketones and characterized by the
3312 # bivalent grouping C=NOH [Webster's Tenth]
3315 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3316 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3317 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3318 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3323 my $kid = $op->first;
3324 my($binop, $var, $re, $repl) = ("", "", "", "");
3325 if ($op->flags & OPf_STACKED) {
3327 $var = $self->deparse($kid, 20);
3328 $kid = $kid->sibling;
3331 if (null($op->pmreplroot)) {
3332 $repl = $self->dq($kid);
3333 $kid = $kid->sibling;
3335 $repl = $op->pmreplroot->first; # skip substcont
3336 while ($repl->name eq "entereval") {
3337 $repl = $repl->first;
3340 if ($op->pmflags & PMf_EVAL) {
3341 $repl = $self->deparse($repl, 0);
3343 $repl = $self->dq($repl);
3347 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3349 $re = $self->deparse($kid, 1);
3351 $flags .= "e" if $op->pmflags & PMf_EVAL;
3352 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3353 $flags .= "i" if $op->pmflags & PMf_FOLD;
3354 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3355 $flags .= "o" if $op->pmflags & PMf_KEEP;
3356 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3357 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3358 $flags = $substwords{$flags} if $substwords{$flags};
3360 return $self->maybe_parens("$var =~ s"
3361 . double_delim($re, $repl) . $flags,
3364 return "s". double_delim($re, $repl) . $flags;
3373 B::Deparse - Perl compiler backend to produce perl code
3377 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3378 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3382 B::Deparse is a backend module for the Perl compiler that generates
3383 perl source code, based on the internal compiled structure that perl
3384 itself creates after parsing a program. The output of B::Deparse won't
3385 be exactly the same as the original source, since perl doesn't keep
3386 track of comments or whitespace, and there isn't a one-to-one
3387 correspondence between perl's syntactical constructions and their
3388 compiled form, but it will often be close. When you use the B<-p>
3389 option, the output also includes parentheses even when they are not
3390 required by precedence, which can make it easy to see if perl is
3391 parsing your expressions the way you intended.
3393 Please note that this module is mainly new and untested code and is
3394 still under development, so it may change in the future.
3398 As with all compiler backend options, these must follow directly after
3399 the '-MO=Deparse', separated by a comma but not any white space.
3405 Add '#line' declarations to the output based on the line and file
3406 locations of the original code.
3410 Print extra parentheses. Without this option, B::Deparse includes
3411 parentheses in its output only when they are needed, based on the
3412 structure of your program. With B<-p>, it uses parentheses (almost)
3413 whenever they would be legal. This can be useful if you are used to
3414 LISP, or if you want to see how perl parses your input. If you say
3416 if ($var & 0x7f == 65) {print "Gimme an A!"}
3417 print ($which ? $a : $b), "\n";
3418 $name = $ENV{USER} or "Bob";
3420 C<B::Deparse,-p> will print
3423 print('Gimme an A!')
3425 (print(($which ? $a : $b)), '???');
3426 (($name = $ENV{'USER'}) or '???')
3428 which probably isn't what you intended (the C<'???'> is a sign that
3429 perl optimized away a constant value).
3433 Expand double-quoted strings into the corresponding combinations of
3434 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3437 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3441 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3442 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3444 Note that the expanded form represents the way perl handles such
3445 constructions internally -- this option actually turns off the reverse
3446 translation that B::Deparse usually does. On the other hand, note that
3447 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3448 of $y into a string before doing the assignment.
3452 Normally, B::Deparse deparses the main code of a program, and all the subs
3453 defined in the same file. To include subs defined in other files, pass the
3454 B<-f> option with the filename. You can pass the B<-f> option several times, to
3455 include more than one secondary file. (Most of the time you don't want to
3456 use it at all.) You can also use this option to include subs which are
3457 defined in the scope of a B<#line> directive with two parameters.
3459 =item B<-s>I<LETTERS>
3461 Tweak the style of B::Deparse's output. The letters should follow
3462 directly after the 's', with no space or punctuation. The following
3463 options are available:
3469 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3486 The default is not to cuddle.
3490 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3494 Use tabs for each 8 columns of indent. The default is to use only spaces.
3495 For instance, if the style options are B<-si4T>, a line that's indented
3496 3 times will be preceded by one tab and four spaces; if the options were
3497 B<-si8T>, the same line would be preceded by three tabs.
3499 =item B<v>I<STRING>B<.>
3501 Print I<STRING> for the value of a constant that can't be determined
3502 because it was optimized away (mnemonic: this happens when a constant
3503 is used in B<v>oid context). The end of the string is marked by a period.
3504 The string should be a valid perl expression, generally a constant.
3505 Note that unless it's a number, it probably needs to be quoted, and on
3506 a command line quotes need to be protected from the shell. Some
3507 conventional values include 0, 1, 42, '', 'foo', and
3508 'Useless use of constant omitted' (which may need to be
3509 B<-sv"'Useless use of constant omitted'.">
3510 or something similar depending on your shell). The default is '???'.
3511 If you're using B::Deparse on a module or other file that's require'd,
3512 you shouldn't use a value that evaluates to false, since the customary
3513 true constant at the end of a module will be in void context when the
3514 file is compiled as a main program.
3520 Expand conventional syntax constructions into equivalent ones that expose
3521 their internal operation. I<LEVEL> should be a digit, with higher values
3522 meaning more expansion. As with B<-q>, this actually involves turning off
3523 special cases in B::Deparse's normal operations.
3525 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3526 while loops with continue blocks; for instance
3528 for ($i = 0; $i < 10; ++$i) {
3541 Note that in a few cases this translation can't be perfectly carried back
3542 into the source code -- if the loop's initializer declares a my variable,
3543 for instance, it won't have the correct scope outside of the loop.
3545 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3546 expressions using C<&&>, C<?:> and C<do {}>; for instance
3548 print 'hi' if $nice;
3560 $nice and print 'hi';
3561 $nice and do { print 'hi' };
3562 $nice ? do { print 'hi' } : do { print 'bye' };
3564 Long sequences of elsifs will turn into nested ternary operators, which
3565 B::Deparse doesn't know how to indent nicely.
3569 =head1 USING B::Deparse AS A MODULE
3574 $deparse = B::Deparse->new("-p", "-sC");
3575 $body = $deparse->coderef2text(\&func);
3576 eval "sub func $body"; # the inverse operation
3580 B::Deparse can also be used on a sub-by-sub basis from other perl
3585 $deparse = B::Deparse->new(OPTIONS)
3587 Create an object to store the state of a deparsing operation and any
3588 options. The options are the same as those that can be given on the
3589 command line (see L</OPTIONS>); options that are separated by commas
3590 after B<-MO=Deparse> should be given as separate strings. Some
3591 options, like B<-u>, don't make sense for a single subroutine, so
3594 =head2 ambient_pragmas
3596 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3598 The compilation of a subroutine can be affected by a few compiler
3599 directives, B<pragmas>. These are:
3613 Assigning to the special variable $[
3633 Ordinarily, if you use B::Deparse on a subroutine which has
3634 been compiled in the presence of one or more of these pragmas,
3635 the output will include statements to turn on the appropriate
3636 directives. So if you then compile the code returned by coderef2text,
3637 it will behave the same way as the subroutine which you deparsed.
3639 However, you may know that you intend to use the results in a
3640 particular context, where some pragmas are already in scope. In
3641 this case, you use the B<ambient_pragmas> method to describe the
3642 assumptions you wish to make.
3644 The parameters it accepts are:
3650 Takes a string, possibly containing several values separated
3651 by whitespace. The special values "all" and "none" mean what you'd
3654 $deparse->ambient_pragmas(strict => 'subs refs');
3658 Takes a number, the value of the array base $[.
3666 If the value is true, then the appropriate pragma is assumed to
3667 be in the ambient scope, otherwise not.
3671 Takes a string, possibly containing a whitespace-separated list of
3672 values. The values "all" and "none" are special. It's also permissible
3673 to pass an array reference here.
3675 $deparser->ambient_pragmas(re => 'eval');
3680 Takes a string, possibly containing a whitespace-separated list of
3681 values. The values "all" and "none" are special, again. It's also
3682 permissible to pass an array reference here.
3684 $deparser->ambient_pragmas(warnings => [qw[void io]]);
3686 If one of the values is the string "FATAL", then all the warnings
3687 in that list will be considered fatal, just as with the B<warnings>
3688 pragma itself. Should you need to specify that some warnings are
3689 fatal, and others are merely enabled, you can pass the B<warnings>
3692 $deparser->ambient_pragmas(
3694 warnings => [FATAL => qw/void io/],
3697 See L<perllexwarn> for more information about lexical warnings.
3703 These two parameters are used to specify the ambient pragmas in
3704 the format used by the special variables $^H and ${^WARNING_BITS}.
3706 They exist principally so that you can write code like:
3708 { my ($hint_bits, $warning_bits);
3709 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3710 $deparser->ambient_pragmas (
3711 hint_bits => $hint_bits,
3712 warning_bits => $warning_bits,
3716 which specifies that the ambient pragmas are exactly those which
3717 are in scope at the point of calling.
3723 $body = $deparse->coderef2text(\&func)
3724 $body = $deparse->coderef2text(sub ($$) { ... })
3726 Return source code for the body of a subroutine (a block, optionally
3727 preceded by a prototype in parens), given a reference to the
3728 sub. Because a subroutine can have no names, or more than one name,
3729 this method doesn't return a complete subroutine definition -- if you
3730 want to eval the result, you should prepend "sub subname ", or "sub "
3731 for an anonymous function constructor. Unless the sub was defined in
3732 the main:: package, the code will include a package declaration.
3736 See the 'to do' list at the beginning of the module file.
3740 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3741 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3742 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3743 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.