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, "\f".$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, "\f".join(", ", @exprs)."\n" if @exprs;
718 return join("", @text) . "\f.";
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);
947 if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
948 $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
950 push @exprs, $expr . $self->for_loop($ops[$i], 0);
954 $expr .= $self->deparse($ops[$i], 0);
956 push @exprs, $expr if length $expr;
958 return join(";\n", @exprs);
962 my($real_block, $self, $op, $cx) = @_;
966 local(@$self{qw'curstash warnings hints'})
967 = @$self{qw'curstash warnings hints'} if $real_block;
969 $kid = $op->first->sibling; # skip enter
970 if (is_miniwhile($kid)) {
971 my $top = $kid->first;
972 my $name = $top->name;
973 if ($name eq "and") {
975 } elsif ($name eq "or") {
977 } else { # no conditional -> while 1 or until 0
978 return $self->deparse($top->first, 1) . " while 1";
980 my $cond = $top->first;
981 my $body = $cond->sibling->first; # skip lineseq
982 $cond = $self->deparse($cond, 1);
983 $body = $self->deparse($body, 1);
984 return "$body $name $cond";
989 for (; !null($kid); $kid = $kid->sibling) {
992 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
993 return "do { " . $self->lineseq(@kids) . " }";
995 my $lineseq = $self->lineseq(@kids);
996 return (length ($lineseq) ? "$lineseq;" : "");
1000 sub pp_scope { scopeop(0, @_); }
1001 sub pp_lineseq { scopeop(0, @_); }
1002 sub pp_leave { scopeop(1, @_); }
1004 # The BEGIN {} is used here because otherwise this code isn't executed
1005 # when you run B::Deparse on itself.
1007 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1008 "ENV", "ARGV", "ARGVOUT", "_"); }
1013 Carp::confess() if $gv->isa("B::CV");
1014 my $stash = $gv->STASH->NAME;
1015 my $name = $gv->SAFENAME;
1016 if ($stash eq $self->{'curstash'} or $globalnames{$name}
1017 or $name =~ /^[^A-Za-z_]/)
1021 $stash = $stash . "::";
1023 if ($name =~ /^\^../) {
1024 $name = "{$name}"; # ${^WARNING_BITS} etc
1026 return $stash . $name;
1029 # Return the name to use for a stash variable.
1030 # If a lexical with the same name is in scope, it may need to be
1032 sub stash_variable {
1033 my ($self, $prefix, $name) = @_;
1035 return "$prefix$name" if $name =~ /::/;
1037 unless ($prefix eq '$' || $prefix eq '@' ||
1038 $prefix eq '%' || $prefix eq '$#') {
1039 return "$prefix$name";
1042 my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
1043 return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
1044 return "$prefix$name";
1048 my ($self, $name) = @_;
1049 $self->populate_curcvlex() if !defined $self->{'curcvlex'};
1051 my $seq = $self->{'curcop'}->cop_seq;
1052 return 0 if !exists $self->{'curcvlex'}{$name};
1053 for my $a (@{$self->{'curcvlex'}{$name}}) {
1054 my ($st, $en) = @$a;
1055 return 1 if $seq > $st && $seq <= $en;
1060 sub populate_curcvlex {
1062 for (my $cv = $self->{'curcv'}; $$cv; $cv = $cv->OUTSIDE) {
1063 my @padlist = $cv->PADLIST->ARRAY;
1064 my @ns = $padlist[0]->ARRAY;
1066 for (my $i=0; $i<@ns; ++$i) {
1067 next if class($ns[$i]) eq "SPECIAL";
1068 if (class($ns[$i]) eq "PV") {
1069 # Probably that pesky lexical @_
1072 my $name = $ns[$i]->PVX;
1073 my $seq_st = $ns[$i]->NVX;
1074 my $seq_en = int($ns[$i]->IVX);
1076 push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
1081 # Recurses down the tree, looking for a COP
1083 my ($self, $op) = @_;
1084 if ($op->flags & OPf_KIDS) {
1085 for (my $o=$op->first; $$o; $o=$o->sibling) {
1086 return $o if is_state($o);
1087 my $r = $self->find_cop($o);
1088 return $r if defined $r;
1094 # Returns a list of subs which should be inserted before the COP
1096 my ($self, $op, $out_seq) = @_;
1097 my $seq = $op->cop_seq;
1098 # If we have nephews, then our sequence number indicates
1099 # the cop_seq of the end of some sort of scope.
1100 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1101 and my $ncop = $self->find_cop($op->sibling)) {
1102 $seq = $ncop->cop_seq;
1104 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1105 return $self->seq_subs($seq);
1109 my ($self, $seq) = @_;
1111 #push @text, "# ($seq)\n";
1113 while (scalar(@{$self->{'subs_todo'}})
1114 and $seq > $self->{'subs_todo'}[0][0]) {
1115 push @text, $self->next_todo;
1120 # Notice how subs and formats are inserted between statements here;
1121 # also $[ assignments and pragmas.
1125 $self->{'curcop'} = $op;
1127 #push @text, "# ", $op->cop_seq, "\n";
1128 push @text, $self->cop_subs($op);
1129 push @text, $op->label . ": " if $op->label;
1130 my $stash = $op->stashpv;
1131 if ($stash ne $self->{'curstash'}) {
1132 push @text, "package $stash;\n";
1133 $self->{'curstash'} = $stash;
1135 if ($self->{'linenums'}) {
1136 push @text, "\f#line " . $op->line .
1137 ' "' . $op->file, qq'"\n';
1140 if ($self->{'arybase'} != $op->arybase) {
1141 push @text, '$[ = '. $op->arybase .";\n";
1142 $self->{'arybase'} = $op->arybase;
1145 my $warnings = $op->warnings;
1147 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1148 $warning_bits = $warnings::Bits{"all"};
1150 elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
1151 $warning_bits = "\0"x12;
1153 elsif ($warnings->isa("B::SPECIAL")) {
1154 $warning_bits = undef;
1157 $warning_bits = $warnings->PV & WARN_MASK;
1160 if (defined ($warning_bits) and
1161 !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
1162 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1163 $self->{'warnings'} = $warning_bits;
1166 if ($self->{'hints'} != $op->private) {
1167 push @text, declare_hints($self->{'hints'}, $op->private);
1168 $self->{'hints'} = $op->private;
1171 return join("", @text);
1174 sub declare_warnings {
1175 my ($from, $to) = @_;
1176 if ($to eq warnings::bits("all")) {
1177 return "use warnings;\n";
1179 elsif ($to eq "\0"x12) {
1180 return "no warnings;\n";
1182 return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
1186 my ($from, $to) = @_;
1188 return sprintf "BEGIN {\$^H &= ~0xFF; \$^H |= %x}\n", $bits;
1191 sub pp_dbstate { pp_nextstate(@_) }
1192 sub pp_setstate { pp_nextstate(@_) }
1194 sub pp_unstack { return "" } # see also leaveloop
1198 my($op, $cx, $name) = @_;
1204 my($op, $cx, $name) = @_;
1212 sub pp_wantarray { baseop(@_, "wantarray") }
1213 sub pp_fork { baseop(@_, "fork") }
1214 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1215 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1216 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1217 sub pp_tms { baseop(@_, "times") }
1218 sub pp_ghostent { baseop(@_, "gethostent") }
1219 sub pp_gnetent { baseop(@_, "getnetent") }
1220 sub pp_gprotoent { baseop(@_, "getprotoent") }
1221 sub pp_gservent { baseop(@_, "getservent") }
1222 sub pp_ehostent { baseop(@_, "endhostent") }
1223 sub pp_enetent { baseop(@_, "endnetent") }
1224 sub pp_eprotoent { baseop(@_, "endprotoent") }
1225 sub pp_eservent { baseop(@_, "endservent") }
1226 sub pp_gpwent { baseop(@_, "getpwent") }
1227 sub pp_spwent { baseop(@_, "setpwent") }
1228 sub pp_epwent { baseop(@_, "endpwent") }
1229 sub pp_ggrent { baseop(@_, "getgrent") }
1230 sub pp_sgrent { baseop(@_, "setgrent") }
1231 sub pp_egrent { baseop(@_, "endgrent") }
1232 sub pp_getlogin { baseop(@_, "getlogin") }
1234 sub POSTFIX () { 1 }
1236 # I couldn't think of a good short name, but this is the category of
1237 # symbolic unary operators with interesting precedence
1241 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1242 my $kid = $op->first;
1243 $kid = $self->deparse($kid, $prec);
1244 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1248 sub pp_preinc { pfixop(@_, "++", 23) }
1249 sub pp_predec { pfixop(@_, "--", 23) }
1250 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1251 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1252 sub pp_i_preinc { pfixop(@_, "++", 23) }
1253 sub pp_i_predec { pfixop(@_, "--", 23) }
1254 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1255 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1256 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1258 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1262 if ($op->first->name =~ /^(i_)?negate$/) {
1264 $self->pfixop($op, $cx, "-", 21.5);
1266 $self->pfixop($op, $cx, "-", 21);
1269 sub pp_i_negate { pp_negate(@_) }
1275 $self->pfixop($op, $cx, "not ", 4);
1277 $self->pfixop($op, $cx, "!", 21);
1283 my($op, $cx, $name) = @_;
1285 if ($op->flags & OPf_KIDS) {
1287 if (defined prototype("CORE::$name")
1288 && prototype("CORE::$name") =~ /^;?\*/
1289 && $kid->name eq "rv2gv") {
1293 return $self->maybe_parens_unop($name, $kid, $cx);
1295 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1299 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1300 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1301 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1302 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1303 sub pp_defined { unop(@_, "defined") }
1304 sub pp_undef { unop(@_, "undef") }
1305 sub pp_study { unop(@_, "study") }
1306 sub pp_ref { unop(@_, "ref") }
1307 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1309 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1310 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1311 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1312 sub pp_srand { unop(@_, "srand") }
1313 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1314 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1315 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1316 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1317 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1318 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1319 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1321 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1322 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1323 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1325 sub pp_each { unop(@_, "each") }
1326 sub pp_values { unop(@_, "values") }
1327 sub pp_keys { unop(@_, "keys") }
1328 sub pp_pop { unop(@_, "pop") }
1329 sub pp_shift { unop(@_, "shift") }
1331 sub pp_caller { unop(@_, "caller") }
1332 sub pp_reset { unop(@_, "reset") }
1333 sub pp_exit { unop(@_, "exit") }
1334 sub pp_prototype { unop(@_, "prototype") }
1336 sub pp_close { unop(@_, "close") }
1337 sub pp_fileno { unop(@_, "fileno") }
1338 sub pp_umask { unop(@_, "umask") }
1339 sub pp_untie { unop(@_, "untie") }
1340 sub pp_tied { unop(@_, "tied") }
1341 sub pp_dbmclose { unop(@_, "dbmclose") }
1342 sub pp_getc { unop(@_, "getc") }
1343 sub pp_eof { unop(@_, "eof") }
1344 sub pp_tell { unop(@_, "tell") }
1345 sub pp_getsockname { unop(@_, "getsockname") }
1346 sub pp_getpeername { unop(@_, "getpeername") }
1348 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1349 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1350 sub pp_readlink { unop(@_, "readlink") }
1351 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1352 sub pp_readdir { unop(@_, "readdir") }
1353 sub pp_telldir { unop(@_, "telldir") }
1354 sub pp_rewinddir { unop(@_, "rewinddir") }
1355 sub pp_closedir { unop(@_, "closedir") }
1356 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1357 sub pp_localtime { unop(@_, "localtime") }
1358 sub pp_gmtime { unop(@_, "gmtime") }
1359 sub pp_alarm { unop(@_, "alarm") }
1360 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1362 sub pp_dofile { unop(@_, "do") }
1363 sub pp_entereval { unop(@_, "eval") }
1365 sub pp_ghbyname { unop(@_, "gethostbyname") }
1366 sub pp_gnbyname { unop(@_, "getnetbyname") }
1367 sub pp_gpbyname { unop(@_, "getprotobyname") }
1368 sub pp_shostent { unop(@_, "sethostent") }
1369 sub pp_snetent { unop(@_, "setnetent") }
1370 sub pp_sprotoent { unop(@_, "setprotoent") }
1371 sub pp_sservent { unop(@_, "setservent") }
1372 sub pp_gpwnam { unop(@_, "getpwnam") }
1373 sub pp_gpwuid { unop(@_, "getpwuid") }
1374 sub pp_ggrnam { unop(@_, "getgrnam") }
1375 sub pp_ggrgid { unop(@_, "getgrgid") }
1377 sub pp_lock { unop(@_, "lock") }
1383 if ($op->private & OPpEXISTS_SUB) {
1384 # Checking for the existence of a subroutine
1385 return $self->maybe_parens_func("exists",
1386 $self->pp_rv2cv($op->first, 16), $cx, 16);
1388 if ($op->flags & OPf_SPECIAL) {
1389 # Array element, not hash element
1390 return $self->maybe_parens_func("exists",
1391 $self->pp_aelem($op->first, 16), $cx, 16);
1393 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1401 if ($op->private & OPpSLICE) {
1402 if ($op->flags & OPf_SPECIAL) {
1403 # Deleting from an array, not a hash
1404 return $self->maybe_parens_func("delete",
1405 $self->pp_aslice($op->first, 16),
1408 return $self->maybe_parens_func("delete",
1409 $self->pp_hslice($op->first, 16),
1412 if ($op->flags & OPf_SPECIAL) {
1413 # Deleting from an array, not a hash
1414 return $self->maybe_parens_func("delete",
1415 $self->pp_aelem($op->first, 16),
1418 return $self->maybe_parens_func("delete",
1419 $self->pp_helem($op->first, 16),
1427 if (class($op) eq "UNOP" and $op->first->name eq "const"
1428 and $op->first->private & OPpCONST_BARE)
1430 my $name = $self->const_sv($op->first)->PV;
1433 return "require $name";
1435 $self->unop($op, $cx, "require");
1442 my $kid = $op->first;
1443 if (not null $kid->sibling) {
1444 # XXX Was a here-doc
1445 return $self->dquote($op);
1447 $self->unop(@_, "scalar");
1454 #cluck "curcv was undef" unless $self->{curcv};
1455 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1461 my $kid = $op->first;
1462 if ($kid->name eq "null") {
1464 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1465 my($pre, $post) = @{{"anonlist" => ["[","]"],
1466 "anonhash" => ["{","}"]}->{$kid->name}};
1468 $kid = $kid->first->sibling; # skip pushmark
1469 for (; !null($kid); $kid = $kid->sibling) {
1470 $expr = $self->deparse($kid, 6);
1473 return $pre . join(", ", @exprs) . $post;
1474 } elsif (!null($kid->sibling) and
1475 $kid->sibling->name eq "anoncode") {
1477 $self->deparse_sub($self->padval($kid->sibling->targ));
1478 } elsif ($kid->name eq "pushmark") {
1479 my $sib_name = $kid->sibling->name;
1480 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1481 and not $kid->sibling->flags & OPf_REF)
1483 # The @a in \(@a) isn't in ref context, but only when the
1485 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1486 } elsif ($sib_name eq 'entersub') {
1487 my $text = $self->deparse($kid->sibling, 1);
1488 # Always show parens for \(&func()), but only with -p otherwise
1489 $text = "($text)" if $self->{'parens'}
1490 or $kid->sibling->private & OPpENTERSUB_AMPER;
1495 $self->pfixop($op, $cx, "\\", 20);
1498 sub pp_srefgen { pp_refgen(@_) }
1503 my $kid = $op->first;
1504 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1505 return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
1506 return $self->unop($op, $cx, "readline");
1509 # Unary operators that can occur as pseudo-listops inside double quotes
1512 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1514 if ($op->flags & OPf_KIDS) {
1516 # If there's more than one kid, the first is an ex-pushmark.
1517 $kid = $kid->sibling if not null $kid->sibling;
1518 return $self->maybe_parens_unop($name, $kid, $cx);
1520 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1524 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1525 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1526 sub pp_uc { dq_unop(@_, "uc") }
1527 sub pp_lc { dq_unop(@_, "lc") }
1528 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1532 my ($op, $cx, $name) = @_;
1533 if (class($op) eq "PVOP") {
1534 return "$name " . $op->pv;
1535 } elsif (class($op) eq "OP") {
1537 } elsif (class($op) eq "UNOP") {
1538 # Note -- loop exits are actually exempt from the
1539 # looks-like-a-func rule, but a few extra parens won't hurt
1540 return $self->maybe_parens_unop($name, $op->first, $cx);
1544 sub pp_last { loopex(@_, "last") }
1545 sub pp_next { loopex(@_, "next") }
1546 sub pp_redo { loopex(@_, "redo") }
1547 sub pp_goto { loopex(@_, "goto") }
1548 sub pp_dump { loopex(@_, "dump") }
1552 my($op, $cx, $name) = @_;
1553 if (class($op) eq "UNOP") {
1554 # Genuine `-X' filetests are exempt from the LLAFR, but not
1555 # l?stat(); for the sake of clarity, give'em all parens
1556 return $self->maybe_parens_unop($name, $op->first, $cx);
1557 } elsif (class($op) eq "SVOP") {
1558 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1559 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1564 sub pp_lstat { ftst(@_, "lstat") }
1565 sub pp_stat { ftst(@_, "stat") }
1566 sub pp_ftrread { ftst(@_, "-R") }
1567 sub pp_ftrwrite { ftst(@_, "-W") }
1568 sub pp_ftrexec { ftst(@_, "-X") }
1569 sub pp_fteread { ftst(@_, "-r") }
1570 sub pp_ftewrite { ftst(@_, "-w") }
1571 sub pp_fteexec { ftst(@_, "-x") }
1572 sub pp_ftis { ftst(@_, "-e") }
1573 sub pp_fteowned { ftst(@_, "-O") }
1574 sub pp_ftrowned { ftst(@_, "-o") }
1575 sub pp_ftzero { ftst(@_, "-z") }
1576 sub pp_ftsize { ftst(@_, "-s") }
1577 sub pp_ftmtime { ftst(@_, "-M") }
1578 sub pp_ftatime { ftst(@_, "-A") }
1579 sub pp_ftctime { ftst(@_, "-C") }
1580 sub pp_ftsock { ftst(@_, "-S") }
1581 sub pp_ftchr { ftst(@_, "-c") }
1582 sub pp_ftblk { ftst(@_, "-b") }
1583 sub pp_ftfile { ftst(@_, "-f") }
1584 sub pp_ftdir { ftst(@_, "-d") }
1585 sub pp_ftpipe { ftst(@_, "-p") }
1586 sub pp_ftlink { ftst(@_, "-l") }
1587 sub pp_ftsuid { ftst(@_, "-u") }
1588 sub pp_ftsgid { ftst(@_, "-g") }
1589 sub pp_ftsvtx { ftst(@_, "-k") }
1590 sub pp_fttty { ftst(@_, "-t") }
1591 sub pp_fttext { ftst(@_, "-T") }
1592 sub pp_ftbinary { ftst(@_, "-B") }
1594 sub SWAP_CHILDREN () { 1 }
1595 sub ASSIGN () { 2 } # has OP= variant
1596 sub LIST_CONTEXT () { 4 } # Assignment is in list context
1602 my $name = $op->name;
1603 if ($name eq "concat" and $op->first->name eq "concat") {
1604 # avoid spurious `=' -- see comment in pp_concat
1607 if ($name eq "null" and class($op) eq "UNOP"
1608 and $op->first->name =~ /^(and|x?or)$/
1609 and null $op->first->sibling)
1611 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1612 # with a null that's used as the common end point of the two
1613 # flows of control. For precedence purposes, ignore it.
1614 # (COND_EXPRs have these too, but we don't bother with
1615 # their associativity).
1616 return assoc_class($op->first);
1618 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1621 # Left associative operators, like `+', for which
1622 # $a + $b + $c is equivalent to ($a + $b) + $c
1625 %left = ('multiply' => 19, 'i_multiply' => 19,
1626 'divide' => 19, 'i_divide' => 19,
1627 'modulo' => 19, 'i_modulo' => 19,
1629 'add' => 18, 'i_add' => 18,
1630 'subtract' => 18, 'i_subtract' => 18,
1632 'left_shift' => 17, 'right_shift' => 17,
1634 'bit_or' => 12, 'bit_xor' => 12,
1636 'or' => 2, 'xor' => 2,
1640 sub deparse_binop_left {
1642 my($op, $left, $prec) = @_;
1643 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1644 and $left{assoc_class($op)} == $left{assoc_class($left)})
1646 return $self->deparse($left, $prec - .00001);
1648 return $self->deparse($left, $prec);
1652 # Right associative operators, like `=', for which
1653 # $a = $b = $c is equivalent to $a = ($b = $c)
1656 %right = ('pow' => 22,
1657 'sassign=' => 7, 'aassign=' => 7,
1658 'multiply=' => 7, 'i_multiply=' => 7,
1659 'divide=' => 7, 'i_divide=' => 7,
1660 'modulo=' => 7, 'i_modulo=' => 7,
1662 'add=' => 7, 'i_add=' => 7,
1663 'subtract=' => 7, 'i_subtract=' => 7,
1665 'left_shift=' => 7, 'right_shift=' => 7,
1667 'bit_or=' => 7, 'bit_xor=' => 7,
1673 sub deparse_binop_right {
1675 my($op, $right, $prec) = @_;
1676 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1677 and $right{assoc_class($op)} == $right{assoc_class($right)})
1679 return $self->deparse($right, $prec - .00001);
1681 return $self->deparse($right, $prec);
1687 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1688 my $left = $op->first;
1689 my $right = $op->last;
1691 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1695 if ($flags & SWAP_CHILDREN) {
1696 ($left, $right) = ($right, $left);
1698 $left = $self->deparse_binop_left($op, $left, $prec);
1699 $left = "($left)" if $flags & LIST_CONTEXT && $left =~ /^\$/;
1700 $right = $self->deparse_binop_right($op, $right, $prec);
1701 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1704 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1705 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1706 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1707 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1708 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1709 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1710 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1711 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1712 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1713 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1714 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1716 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1717 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1718 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1719 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1720 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1722 sub pp_eq { binop(@_, "==", 14) }
1723 sub pp_ne { binop(@_, "!=", 14) }
1724 sub pp_lt { binop(@_, "<", 15) }
1725 sub pp_gt { binop(@_, ">", 15) }
1726 sub pp_ge { binop(@_, ">=", 15) }
1727 sub pp_le { binop(@_, "<=", 15) }
1728 sub pp_ncmp { binop(@_, "<=>", 14) }
1729 sub pp_i_eq { binop(@_, "==", 14) }
1730 sub pp_i_ne { binop(@_, "!=", 14) }
1731 sub pp_i_lt { binop(@_, "<", 15) }
1732 sub pp_i_gt { binop(@_, ">", 15) }
1733 sub pp_i_ge { binop(@_, ">=", 15) }
1734 sub pp_i_le { binop(@_, "<=", 15) }
1735 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1737 sub pp_seq { binop(@_, "eq", 14) }
1738 sub pp_sne { binop(@_, "ne", 14) }
1739 sub pp_slt { binop(@_, "lt", 15) }
1740 sub pp_sgt { binop(@_, "gt", 15) }
1741 sub pp_sge { binop(@_, "ge", 15) }
1742 sub pp_sle { binop(@_, "le", 15) }
1743 sub pp_scmp { binop(@_, "cmp", 14) }
1745 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1746 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
1748 # `.' is special because concats-of-concats are optimized to save copying
1749 # by making all but the first concat stacked. The effect is as if the
1750 # programmer had written `($a . $b) .= $c', except legal.
1751 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1755 my $left = $op->first;
1756 my $right = $op->last;
1759 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1763 $left = $self->deparse_binop_left($op, $left, $prec);
1764 $right = $self->deparse_binop_right($op, $right, $prec);
1765 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1768 # `x' is weird when the left arg is a list
1772 my $left = $op->first;
1773 my $right = $op->last;
1776 if ($op->flags & OPf_STACKED) {
1780 if (null($right)) { # list repeat; count is inside left-side ex-list
1781 my $kid = $left->first->sibling; # skip pushmark
1783 for (; !null($kid->sibling); $kid = $kid->sibling) {
1784 push @exprs, $self->deparse($kid, 6);
1787 $left = "(" . join(", ", @exprs). ")";
1789 $left = $self->deparse_binop_left($op, $left, $prec);
1791 $right = $self->deparse_binop_right($op, $right, $prec);
1792 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1797 my ($op, $cx, $type) = @_;
1798 my $left = $op->first;
1799 my $right = $left->sibling;
1800 $left = $self->deparse($left, 9);
1801 $right = $self->deparse($right, 9);
1802 return $self->maybe_parens("$left $type $right", $cx, 9);
1808 my $flip = $op->first;
1809 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1810 return $self->range($flip->first, $cx, $type);
1813 # one-line while/until is handled in pp_leave
1817 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1818 my $left = $op->first;
1819 my $right = $op->first->sibling;
1820 if ($cx == 0 and is_scope($right) and $blockname
1821 and $self->{'expand'} < 7)
1823 $left = $self->deparse($left, 1);
1824 $right = $self->deparse($right, 0);
1825 return "$blockname ($left) {\n\t$right\n\b}\cK";
1826 } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1827 and $self->{'expand'} < 7) { # $b if $a
1828 $right = $self->deparse($right, 1);
1829 $left = $self->deparse($left, 1);
1830 return "$right $blockname $left";
1831 } elsif ($cx > $lowprec and $highop) { # $a && $b
1832 $left = $self->deparse_binop_left($op, $left, $highprec);
1833 $right = $self->deparse_binop_right($op, $right, $highprec);
1834 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1835 } else { # $a and $b
1836 $left = $self->deparse_binop_left($op, $left, $lowprec);
1837 $right = $self->deparse_binop_right($op, $right, $lowprec);
1838 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1842 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1843 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1845 # xor is syntactically a logop, but it's really a binop (contrary to
1846 # old versions of opcode.pl). Syntax is what matters here.
1847 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1851 my ($op, $cx, $opname) = @_;
1852 my $left = $op->first;
1853 my $right = $op->first->sibling->first; # skip sassign
1854 $left = $self->deparse($left, 7);
1855 $right = $self->deparse($right, 7);
1856 return $self->maybe_parens("$left $opname $right", $cx, 7);
1859 sub pp_andassign { logassignop(@_, "&&=") }
1860 sub pp_orassign { logassignop(@_, "||=") }
1864 my($op, $cx, $name) = @_;
1866 my $parens = ($cx >= 5) || $self->{'parens'};
1867 my $kid = $op->first->sibling;
1868 return $name if null $kid;
1870 if (defined prototype("CORE::$name")
1871 && prototype("CORE::$name") =~ /^;?\*/
1872 && $kid->name eq "rv2gv") {
1873 $first = $self->deparse($kid->first, 6);
1876 $first = $self->deparse($kid, 6);
1878 if ($name eq "chmod" && $first =~ /^\d+$/) {
1879 $first = sprintf("0%o", $first);
1881 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1882 push @exprs, $first;
1883 $kid = $kid->sibling;
1884 for (; !null($kid); $kid = $kid->sibling) {
1885 push @exprs, $self->deparse($kid, 6);
1888 return "$name(" . join(", ", @exprs) . ")";
1890 return "$name " . join(", ", @exprs);
1894 sub pp_bless { listop(@_, "bless") }
1895 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1896 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1897 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1898 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1899 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1900 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1901 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1902 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1903 sub pp_unpack { listop(@_, "unpack") }
1904 sub pp_pack { listop(@_, "pack") }
1905 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1906 sub pp_splice { listop(@_, "splice") }
1907 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1908 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1909 sub pp_reverse { listop(@_, "reverse") }
1910 sub pp_warn { listop(@_, "warn") }
1911 sub pp_die { listop(@_, "die") }
1912 # Actually, return is exempt from the LLAFR (see examples in this very
1913 # module!), but for consistency's sake, ignore that fact
1914 sub pp_return { listop(@_, "return") }
1915 sub pp_open { listop(@_, "open") }
1916 sub pp_pipe_op { listop(@_, "pipe") }
1917 sub pp_tie { listop(@_, "tie") }
1918 sub pp_binmode { listop(@_, "binmode") }
1919 sub pp_dbmopen { listop(@_, "dbmopen") }
1920 sub pp_sselect { listop(@_, "select") }
1921 sub pp_select { listop(@_, "select") }
1922 sub pp_read { listop(@_, "read") }
1923 sub pp_sysopen { listop(@_, "sysopen") }
1924 sub pp_sysseek { listop(@_, "sysseek") }
1925 sub pp_sysread { listop(@_, "sysread") }
1926 sub pp_syswrite { listop(@_, "syswrite") }
1927 sub pp_send { listop(@_, "send") }
1928 sub pp_recv { listop(@_, "recv") }
1929 sub pp_seek { listop(@_, "seek") }
1930 sub pp_fcntl { listop(@_, "fcntl") }
1931 sub pp_ioctl { listop(@_, "ioctl") }
1932 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1933 sub pp_socket { listop(@_, "socket") }
1934 sub pp_sockpair { listop(@_, "sockpair") }
1935 sub pp_bind { listop(@_, "bind") }
1936 sub pp_connect { listop(@_, "connect") }
1937 sub pp_listen { listop(@_, "listen") }
1938 sub pp_accept { listop(@_, "accept") }
1939 sub pp_shutdown { listop(@_, "shutdown") }
1940 sub pp_gsockopt { listop(@_, "getsockopt") }
1941 sub pp_ssockopt { listop(@_, "setsockopt") }
1942 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1943 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1944 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1945 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1946 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1947 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1948 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1949 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1950 sub pp_open_dir { listop(@_, "opendir") }
1951 sub pp_seekdir { listop(@_, "seekdir") }
1952 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1953 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1954 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1955 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1956 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1957 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1958 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1959 sub pp_shmget { listop(@_, "shmget") }
1960 sub pp_shmctl { listop(@_, "shmctl") }
1961 sub pp_shmread { listop(@_, "shmread") }
1962 sub pp_shmwrite { listop(@_, "shmwrite") }
1963 sub pp_msgget { listop(@_, "msgget") }
1964 sub pp_msgctl { listop(@_, "msgctl") }
1965 sub pp_msgsnd { listop(@_, "msgsnd") }
1966 sub pp_msgrcv { listop(@_, "msgrcv") }
1967 sub pp_semget { listop(@_, "semget") }
1968 sub pp_semctl { listop(@_, "semctl") }
1969 sub pp_semop { listop(@_, "semop") }
1970 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1971 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1972 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1973 sub pp_gsbyname { listop(@_, "getservbyname") }
1974 sub pp_gsbyport { listop(@_, "getservbyport") }
1975 sub pp_syscall { listop(@_, "syscall") }
1980 my $text = $self->dq($op->first->sibling); # skip pushmark
1981 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1982 or $text =~ /[<>]/) {
1983 return 'glob(' . single_delim('qq', '"', $text) . ')';
1985 return '<' . $text . '>';
1989 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1990 # be a filehandle. This could probably be better fixed in the core
1991 # by moving the GV lookup into ck_truc.
1997 my $parens = ($cx >= 5) || $self->{'parens'};
1998 my $kid = $op->first->sibling;
2000 if ($op->flags & OPf_SPECIAL) {
2001 # $kid is an OP_CONST
2002 $fh = $self->const_sv($kid)->PV;
2004 $fh = $self->deparse($kid, 6);
2005 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
2007 my $len = $self->deparse($kid->sibling, 6);
2009 return "truncate($fh, $len)";
2011 return "truncate $fh, $len";
2017 my($op, $cx, $name) = @_;
2019 my $kid = $op->first->sibling;
2021 if ($op->flags & OPf_STACKED) {
2023 $indir = $indir->first; # skip rv2gv
2024 if (is_scope($indir)) {
2025 $indir = "{" . $self->deparse($indir, 0) . "}";
2027 $indir = $self->deparse($indir, 24);
2029 $indir = $indir . " ";
2030 $kid = $kid->sibling;
2032 for (; !null($kid); $kid = $kid->sibling) {
2033 $expr = $self->deparse($kid, 6);
2036 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
2040 sub pp_prtf { indirop(@_, "printf") }
2041 sub pp_print { indirop(@_, "print") }
2042 sub pp_sort { indirop(@_, "sort") }
2046 my($op, $cx, $name) = @_;
2048 my $kid = $op->first; # this is the (map|grep)start
2049 $kid = $kid->first->sibling; # skip a pushmark
2050 my $code = $kid->first; # skip a null
2051 if (is_scope $code) {
2052 $code = "{" . $self->deparse($code, 0) . "} ";
2054 $code = $self->deparse($code, 24) . ", ";
2056 $kid = $kid->sibling;
2057 for (; !null($kid); $kid = $kid->sibling) {
2058 $expr = $self->deparse($kid, 6);
2059 push @exprs, $expr if $expr;
2061 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
2064 sub pp_mapwhile { mapop(@_, "map") }
2065 sub pp_grepwhile { mapop(@_, "grep") }
2071 my $kid = $op->first->sibling; # skip pushmark
2073 my $local = "either"; # could be local(...) or my(...)
2074 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2075 # This assumes that no other private flags equal 128, and that
2076 # OPs that store things other than flags in their op_private,
2077 # like OP_AELEMFAST, won't be immediate children of a list.
2078 unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
2080 $local = ""; # or not
2083 if ($lop->name =~ /^pad[ash]v$/) { # my()
2084 ($local = "", last) if $local eq "local";
2086 } elsif ($lop->name ne "undef") { # local()
2087 ($local = "", last) if $local eq "my";
2091 $local = "" if $local eq "either"; # no point if it's all undefs
2092 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2093 for (; !null($kid); $kid = $kid->sibling) {
2095 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2100 $self->{'avoid_local'}{$$lop}++;
2101 $expr = $self->deparse($kid, 6);
2102 delete $self->{'avoid_local'}{$$lop};
2104 $expr = $self->deparse($kid, 6);
2109 return "$local(" . join(", ", @exprs) . ")";
2111 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2115 sub is_ifelse_cont {
2117 return ($op->name eq "null" and class($op) eq "UNOP"
2118 and $op->first->name =~ /^(and|cond_expr)$/
2119 and is_scope($op->first->first->sibling));
2125 my $cond = $op->first;
2126 my $true = $cond->sibling;
2127 my $false = $true->sibling;
2128 my $cuddle = $self->{'cuddle'};
2129 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
2130 (is_scope($false) || is_ifelse_cont($false))
2131 and $self->{'expand'} < 7) {
2132 $cond = $self->deparse($cond, 8);
2133 $true = $self->deparse($true, 8);
2134 $false = $self->deparse($false, 8);
2135 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2138 $cond = $self->deparse($cond, 1);
2139 $true = $self->deparse($true, 0);
2140 my $head = "if ($cond) {\n\t$true\n\b}";
2142 while (!null($false) and is_ifelse_cont($false)) {
2143 my $newop = $false->first;
2144 my $newcond = $newop->first;
2145 my $newtrue = $newcond->sibling;
2146 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2147 $newcond = $self->deparse($newcond, 1);
2148 $newtrue = $self->deparse($newtrue, 0);
2149 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2151 if (!null($false)) {
2152 $false = $cuddle . "else {\n\t" .
2153 $self->deparse($false, 0) . "\n\b}\cK";
2157 return $head . join($cuddle, "", @elsifs) . $false;
2162 my($op, $cx, $init) = @_;
2163 my $enter = $op->first;
2164 my $kid = $enter->sibling;
2165 local(@$self{qw'curstash warnings hints'})
2166 = @$self{qw'curstash warnings hints'};
2171 my $out_seq = $self->{'curcop'}->cop_seq;;
2172 if ($kid->name eq "lineseq") { # bare or infinite loop
2173 if (is_state $kid->last) { # infinite
2174 $head = "while (1) "; # Can't use for(;;) if there's a continue
2180 } elsif ($enter->name eq "enteriter") { # foreach
2181 my $ary = $enter->first->sibling; # first was pushmark
2182 my $var = $ary->sibling;
2183 if ($enter->flags & OPf_STACKED
2184 and not null $ary->first->sibling->sibling)
2186 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2187 $self->deparse($ary->first->sibling->sibling, 9);
2189 $ary = $self->deparse($ary, 1);
2192 if ($enter->flags & OPf_SPECIAL) { # thread special var
2193 $var = $self->pp_threadsv($enter, 1);
2194 } else { # regular my() variable
2195 $var = $self->pp_padsv($enter, 1);
2196 if ($self->padname_sv($enter->targ)->IVX ==
2197 $kid->first->first->sibling->last->cop_seq)
2199 # If the scope of this variable closes at the last
2200 # statement of the loop, it must have been
2202 $var = "my " . $var;
2205 } elsif ($var->name eq "rv2gv") {
2206 $var = $self->pp_rv2sv($var, 1);
2207 } elsif ($var->name eq "gv") {
2208 $var = "\$" . $self->deparse($var, 1);
2210 $head = "foreach $var ($ary) ";
2211 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2212 } elsif ($kid->name eq "null") { # while/until
2214 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2215 $cond = $self->deparse($kid->first, 1);
2216 $head = "$name ($cond) ";
2217 $body = $kid->first->sibling;
2218 } elsif ($kid->name eq "stub") { # bare and empty
2219 return "{;}"; # {} could be a hashref
2221 # If there isn't a continue block, then the next pointer for the loop
2222 # will point to the unstack, which is kid's penultimate child, except
2223 # in a bare loop, when it will point to the leaveloop. When neither of
2224 # these conditions hold, then the third-to-last child in the continue
2225 # block (or the last in a bare loop).
2226 my $cont_start = $enter->nextop;
2228 if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
2230 $cont = $body->last;
2232 $cont = $body->first;
2233 while (!null($cont->sibling->sibling->sibling)) {
2234 $cont = $cont->sibling;
2237 my $state = $body->first;
2238 my $cuddle = $self->{'cuddle'};
2240 for (; $$state != $$cont; $state = $state->sibling) {
2241 push @states, $state;
2243 $body = $self->lineseq(@states);
2244 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2245 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2248 $cont = $cuddle . "continue {\n\t" .
2249 $self->deparse($cont, 0) . "\n\b}\cK";
2252 return "" if !defined $body;
2254 $body = $self->deparse($body, 0);
2257 # If we have say C<{my $x=2; sub x{$x}}>, the sub must go inside
2258 # the loop. So we insert any subs which are due here.
2259 $body .= join"", $self->seq_subs($out_seq);
2261 return $head . "{\n\t" . $body . "\b}" . $cont;
2264 sub pp_leaveloop { loop_common(@_, "") }
2269 my $init = $self->deparse($op, 1);
2270 return $self->loop_common($op->sibling, $cx, $init);
2275 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2278 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2279 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2284 if (class($op) eq "OP") {
2286 return $self->{'ex_const'} if $op->targ == OP_CONST;
2287 } elsif ($op->first->name eq "pushmark") {
2288 return $self->pp_list($op, $cx);
2289 } elsif ($op->first->name eq "enter") {
2290 return $self->pp_leave($op, $cx);
2291 } elsif ($op->targ == OP_STRINGIFY) {
2292 return $self->dquote($op, $cx);
2293 } elsif (!null($op->first->sibling) and
2294 $op->first->sibling->name eq "readline" and
2295 $op->first->sibling->flags & OPf_STACKED) {
2296 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2297 . $self->deparse($op->first->sibling, 7),
2299 } elsif (!null($op->first->sibling) and
2300 $op->first->sibling->name eq "trans" and
2301 $op->first->sibling->flags & OPf_STACKED) {
2302 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2303 . $self->deparse($op->first->sibling, 20),
2306 return $self->deparse($op->first, $cx);
2313 return $self->padname_sv($targ)->PVX;
2319 return substr($self->padname($op->targ), 1); # skip $/@/%
2325 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2328 sub pp_padav { pp_padsv(@_) }
2329 sub pp_padhv { pp_padsv(@_) }
2334 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2335 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2336 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2343 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2349 if (class($op) eq "PADOP") {
2350 return $self->padval($op->padix);
2351 } else { # class($op) eq "SVOP"
2359 my $gv = $self->gv_or_padgv($op);
2360 return $self->maybe_local($op, $cx, $self->stash_variable("\$",
2361 $self->gv_name($gv)));
2367 my $gv = $self->gv_or_padgv($op);
2368 return $self->gv_name($gv);
2374 my $gv = $self->gv_or_padgv($op);
2375 return "\$" . $self->gv_name($gv) . "[" .
2376 ($op->private + $self->{'arybase'}) . "]";
2381 my($op, $cx, $type) = @_;
2382 my $kid = $op->first;
2383 my $str = $self->deparse($kid, 0);
2384 return $self->stash_variable($type, $str) if is_scalar($kid);
2385 return $type ."{$str}";
2388 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2389 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2390 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2396 if ($op->first->name eq "padav") {
2397 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2399 return $self->maybe_local($op, $cx,
2400 $self->rv2x($op->first, $cx, '$#'));
2404 # skip down to the old, ex-rv2cv
2405 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
2410 my $kid = $op->first;
2411 if ($kid->name eq "const") { # constant list
2412 my $av = $self->const_sv($kid);
2413 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2415 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2419 sub is_subscriptable {
2421 if ($op->name =~ /^[ahg]elem/) {
2423 } elsif ($op->name eq "entersub") {
2424 my $kid = $op->first;
2425 return 0 unless null $kid->sibling;
2427 $kid = $kid->sibling until null $kid->sibling;
2428 return 0 if is_scope($kid);
2430 return 0 if $kid->name eq "gv";
2431 return 0 if is_scalar($kid);
2432 return is_subscriptable($kid);
2440 my ($op, $cx, $left, $right, $padname) = @_;
2441 my($array, $idx) = ($op->first, $op->first->sibling);
2442 unless ($array->name eq $padname) { # Maybe this has been fixed
2443 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2445 if ($array->name eq $padname) {
2446 $array = $self->padany($array);
2447 } elsif (is_scope($array)) { # ${expr}[0]
2448 $array = "{" . $self->deparse($array, 0) . "}";
2449 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2450 $array = $self->deparse($array, 24);
2452 # $x[20][3]{hi} or expr->[20]
2453 my $arrow = is_subscriptable($array) ? "" : "->";
2454 return $self->deparse($array, 24) . $arrow .
2455 $left . $self->deparse($idx, 1) . $right;
2457 $idx = $self->deparse($idx, 1);
2459 # Outer parens in an array index will confuse perl
2460 # if we're interpolating in a regular expression, i.e.
2461 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2463 # If $self->{parens}, then an initial '(' will
2464 # definitely be paired with a final ')'. If
2465 # !$self->{parens}, the misleading parens won't
2466 # have been added in the first place.
2468 # [You might think that we could get "(...)...(...)"
2469 # where the initial and final parens do not match
2470 # each other. But we can't, because the above would
2471 # only happen if there's an infix binop between the
2472 # two pairs of parens, and *that* means that the whole
2473 # expression would be parenthesized as well.]
2475 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2477 return "\$" . $array . $left . $idx . $right;
2480 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2481 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2486 my($glob, $part) = ($op->first, $op->last);
2487 $glob = $glob->first; # skip rv2gv
2488 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2489 my $scope = is_scope($glob);
2490 $glob = $self->deparse($glob, 0);
2491 $part = $self->deparse($part, 1);
2492 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2497 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2499 my(@elems, $kid, $array, $list);
2500 if (class($op) eq "LISTOP") {
2502 } else { # ex-hslice inside delete()
2503 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2507 $array = $array->first
2508 if $array->name eq $regname or $array->name eq "null";
2509 if (is_scope($array)) {
2510 $array = "{" . $self->deparse($array, 0) . "}";
2511 } elsif ($array->name eq $padname) {
2512 $array = $self->padany($array);
2514 $array = $self->deparse($array, 24);
2516 $kid = $op->first->sibling; # skip pushmark
2517 if ($kid->name eq "list") {
2518 $kid = $kid->first->sibling; # skip list, pushmark
2519 for (; !null $kid; $kid = $kid->sibling) {
2520 push @elems, $self->deparse($kid, 6);
2522 $list = join(", ", @elems);
2524 $list = $self->deparse($kid, 1);
2526 return "\@" . $array . $left . $list . $right;
2529 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2530 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2535 my $idx = $op->first;
2536 my $list = $op->last;
2538 $list = $self->deparse($list, 1);
2539 $idx = $self->deparse($idx, 1);
2540 return "($list)" . "[$idx]";
2545 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2550 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2556 my $kid = $op->first->sibling; # skip pushmark
2557 my($meth, $obj, @exprs);
2558 if ($kid->name eq "list" and want_list $kid) {
2559 # When an indirect object isn't a bareword but the args are in
2560 # parens, the parens aren't part of the method syntax (the LLAFR
2561 # doesn't apply), but they make a list with OPf_PARENS set that
2562 # doesn't get flattened by the append_elem that adds the method,
2563 # making a (object, arg1, arg2, ...) list where the object
2564 # usually is. This can be distinguished from
2565 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2566 # object) because in the later the list is in scalar context
2567 # as the left side of -> always is, while in the former
2568 # the list is in list context as method arguments always are.
2569 # (Good thing there aren't method prototypes!)
2570 $meth = $kid->sibling;
2571 $kid = $kid->first->sibling; # skip pushmark
2573 $kid = $kid->sibling;
2574 for (; not null $kid; $kid = $kid->sibling) {
2575 push @exprs, $self->deparse($kid, 6);
2579 $kid = $kid->sibling;
2580 for (; not null $kid->sibling; $kid = $kid->sibling) {
2581 push @exprs, $self->deparse($kid, 6);
2585 $obj = $self->deparse($obj, 24);
2586 if ($meth->name eq "method_named") {
2587 $meth = $self->const_sv($meth)->PV;
2589 $meth = $meth->first;
2590 if ($meth->name eq "const") {
2591 # As of 5.005_58, this case is probably obsoleted by the
2592 # method_named case above
2593 $meth = $self->const_sv($meth)->PV; # needs to be bare
2595 $meth = $self->deparse($meth, 1);
2598 my $args = join(", ", @exprs);
2599 $kid = $obj . "->" . $meth;
2601 return $kid . "(" . $args . ")"; # parens mandatory
2607 # returns "&" if the prototype doesn't match the args,
2608 # or ("", $args_after_prototype_demunging) if it does.
2611 my($proto, @args) = @_;
2615 # An unbackslashed @ or % gobbles up the rest of the args
2616 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2618 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2621 return "&" if @args;
2622 } elsif ($chr eq ";") {
2624 } elsif ($chr eq "@" or $chr eq "%") {
2625 push @reals, map($self->deparse($_, 6), @args);
2631 if (want_scalar $arg) {
2632 push @reals, $self->deparse($arg, 6);
2636 } elsif ($chr eq "&") {
2637 if ($arg->name =~ /^(s?refgen|undef)$/) {
2638 push @reals, $self->deparse($arg, 6);
2642 } elsif ($chr eq "*") {
2643 if ($arg->name =~ /^s?refgen$/
2644 and $arg->first->first->name eq "rv2gv")
2646 $real = $arg->first->first; # skip refgen, null
2647 if ($real->first->name eq "gv") {
2648 push @reals, $self->deparse($real, 6);
2650 push @reals, $self->deparse($real->first, 6);
2655 } elsif (substr($chr, 0, 1) eq "\\") {
2656 $chr = substr($chr, 1);
2657 if ($arg->name =~ /^s?refgen$/ and
2658 !null($real = $arg->first) and
2659 ($chr eq "\$" && is_scalar($real->first)
2661 && $real->first->sibling->name
2664 && $real->first->sibling->name
2666 #or ($chr eq "&" # This doesn't work
2667 # && $real->first->name eq "rv2cv")
2669 && $real->first->name eq "rv2gv")))
2671 push @reals, $self->deparse($real, 6);
2678 return "&" if $proto and !$doneok; # too few args and no `;'
2679 return "&" if @args; # too many args
2680 return ("", join ", ", @reals);
2686 return $self->method($op, $cx) unless null $op->first->sibling;
2690 if ($op->flags & OPf_SPECIAL) {
2692 } elsif ($op->private & OPpENTERSUB_AMPER) {
2696 $kid = $kid->first->sibling; # skip ex-list, pushmark
2697 for (; not null $kid->sibling; $kid = $kid->sibling) {
2702 if (is_scope($kid)) {
2704 $kid = "{" . $self->deparse($kid, 0) . "}";
2705 } elsif ($kid->first->name eq "gv") {
2706 my $gv = $self->gv_or_padgv($kid->first);
2707 if (class($gv->CV) ne "SPECIAL") {
2708 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2710 $simple = 1; # only calls of named functions can be prototyped
2711 $kid = $self->deparse($kid, 24);
2712 } elsif (is_scalar $kid->first) {
2714 $kid = $self->deparse($kid, 24);
2717 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2718 $kid = $self->deparse($kid, 24) . $arrow;
2721 # Doesn't matter how many prototypes there are, if
2722 # they haven't happened yet!
2723 my $declared = exists $self->{'subs_declared'}{$kid};
2724 if (!$declared && defined($proto)) {
2725 # Avoid "too early to check prototype" warning
2726 ($amper, $proto) = ('&');
2730 if ($declared and defined $proto and not $amper) {
2731 ($amper, $args) = $self->check_proto($proto, @exprs);
2732 if ($amper eq "&") {
2733 $args = join(", ", map($self->deparse($_, 6), @exprs));
2736 $args = join(", ", map($self->deparse($_, 6), @exprs));
2738 if ($prefix or $amper) {
2739 if ($op->flags & OPf_STACKED) {
2740 return $prefix . $amper . $kid . "(" . $args . ")";
2742 return $prefix . $amper. $kid;
2745 # glob() invocations can be translated into calls of
2746 # CORE::GLOBAL::glob with an second parameter, a number.
2748 if ($kid eq "CORE::GLOBAL::glob") {
2750 $args =~ s/\s*,[^,]+$//;
2753 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2754 # so it must have been translated from a keyword call. Translate
2756 $kid =~ s/^CORE::GLOBAL:://;
2759 return "$kid(" . $args . ")";
2760 } elsif (defined $proto and $proto eq "") {
2762 } elsif (defined $proto and $proto eq "\$") {
2763 return $self->maybe_parens_func($kid, $args, $cx, 16);
2764 } elsif (defined($proto) && $proto or $simple) {
2765 return $self->maybe_parens_func($kid, $args, $cx, 5);
2767 return "$kid(" . $args . ")";
2772 sub pp_enterwrite { unop(@_, "write") }
2774 # escape things that cause interpolation in double quotes,
2775 # but not character escapes
2778 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
2782 # the same, but treat $|, $), $( and $ at the end of the string differently
2785 $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@](?!\||\)|\(|$)|\\[uUlLQE])/$1$2\\$3/g;
2789 # character escapes, but not delimiters that might need to be escaped
2790 sub escape_str { # ASCII, UTF8
2792 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
2794 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2800 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2801 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2805 # Don't do this for regexen
2808 $str =~ s/\\/\\\\/g;
2812 # Remove backslashes which precede literal control characters,
2813 # to avoid creating ambiguity when we escape the latter.
2817 # the insane complexity here is due to the behaviour of "\c\"
2818 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
2822 sub balanced_delim {
2824 my @str = split //, $str;
2825 my($ar, $open, $close, $fail, $c, $cnt);
2826 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2827 ($open, $close) = @$ar;
2828 $fail = 0; $cnt = 0;
2832 } elsif ($c eq $close) {
2841 $fail = 1 if $cnt != 0;
2842 return ($open, "$open$str$close") if not $fail;
2848 my($q, $default, $str) = @_;
2849 return "$default$str$default" if $default and index($str, $default) == -1;
2850 my($succeed, $delim);
2851 ($succeed, $str) = balanced_delim($str);
2852 return "$q$str" if $succeed;
2853 for $delim ('/', '"', '#') {
2854 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2857 $str =~ s/$default/\\$default/g;
2858 return "$default$str$default";
2867 if (class($sv) eq "SPECIAL") {
2868 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2869 } elsif (class($sv) eq "NULL") {
2871 } elsif ($sv->FLAGS & SVf_IOK) {
2872 return $sv->int_value;
2873 } elsif ($sv->FLAGS & SVf_NOK) {
2875 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
2876 return "\\(" . const($sv->RV) . ")"; # constant folded
2879 if ($str =~ /[^ -~]/) { # ASCII for non-printing
2880 return single_delim("qq", '"', uninterp escape_str unback $str);
2882 return single_delim("q", "'", unback $str);
2891 # the constant could be in the pad (under useithreads)
2892 $sv = $self->padval($op->targ) unless $$sv;
2899 if ($op->private & OPpCONST_ARYBASE) {
2902 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2903 # return $self->const_sv($op)->PV;
2905 my $sv = $self->const_sv($op);
2906 # return const($sv);
2908 return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
2914 my $type = $op->name;
2915 if ($type eq "const") {
2916 return '$[' if $op->private & OPpCONST_ARYBASE;
2917 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
2918 } elsif ($type eq "concat") {
2919 my $first = $self->dq($op->first);
2920 my $last = $self->dq($op->last);
2921 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2922 if ($last =~ /^[A-Z\\\^\[\]_?]/) {
2923 $first =~ s/([\$@])\^$/${1}{^}/; # "${^}W" etc
2925 elsif ($last =~ /^[{\[\w]/) {
2926 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2928 return $first . $last;
2929 } elsif ($type eq "uc") {
2930 return '\U' . $self->dq($op->first->sibling) . '\E';
2931 } elsif ($type eq "lc") {
2932 return '\L' . $self->dq($op->first->sibling) . '\E';
2933 } elsif ($type eq "ucfirst") {
2934 return '\u' . $self->dq($op->first->sibling);
2935 } elsif ($type eq "lcfirst") {
2936 return '\l' . $self->dq($op->first->sibling);
2937 } elsif ($type eq "quotemeta") {
2938 return '\Q' . $self->dq($op->first->sibling) . '\E';
2939 } elsif ($type eq "join") {
2940 return $self->deparse($op->last, 26); # was join($", @ary)
2942 return $self->deparse($op, 26);
2950 return single_delim("qx", '`', $self->dq($op->first->sibling));
2956 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2957 return $self->deparse($kid, $cx) if $self->{'unquote'};
2958 $self->maybe_targmy($kid, $cx,
2959 sub {single_delim("qq", '"', $self->dq($_[1]))});
2962 # OP_STRINGIFY is a listop, but it only ever has one arg
2963 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2965 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2966 # note that tr(from)/to/ is OK, but not tr/from/(to)
2968 my($from, $to) = @_;
2969 my($succeed, $delim);
2970 if ($from !~ m[/] and $to !~ m[/]) {
2971 return "/$from/$to/";
2972 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2973 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2976 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2977 return "$from$delim$to$delim" if index($to, $delim) == -1;
2980 return "$from/$to/";
2983 for $delim ('/', '"', '#') { # note no '
2984 return "$delim$from$delim$to$delim"
2985 if index($to . $from, $delim) == -1;
2987 $from =~ s[/][\\/]g;
2989 return "/$from/$to/";
2995 if ($n == ord '\\') {
2997 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2999 } elsif ($n == ord "\a") {
3001 } elsif ($n == ord "\b") {
3003 } elsif ($n == ord "\t") {
3005 } elsif ($n == ord "\n") {
3007 } elsif ($n == ord "\e") {
3009 } elsif ($n == ord "\f") {
3011 } elsif ($n == ord "\r") {
3013 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
3014 return '\\c' . chr(ord("@") + $n);
3016 # return '\x' . sprintf("%02x", $n);
3017 return '\\' . sprintf("%03o", $n);
3023 my($str, $c, $tr) = ("");
3024 for ($c = 0; $c < @chars; $c++) {
3027 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
3028 $chars[$c + 2] == $tr + 2)
3030 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
3033 $str .= pchr($chars[$c]);
3039 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
3042 sub tr_decode_byte {
3043 my($table, $flags) = @_;
3044 my(@table) = unpack("s256", $table);
3045 my($c, $tr, @from, @to, @delfrom, $delhyphen);
3046 if ($table[ord "-"] != -1 and
3047 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
3049 $tr = $table[ord "-"];
3050 $table[ord "-"] = -1;
3054 } else { # -2 ==> delete
3058 for ($c = 0; $c < 256; $c++) {
3061 push @from, $c; push @to, $tr;
3062 } elsif ($tr == -2) {
3066 @from = (@from, @delfrom);
3067 if ($flags & OPpTRANS_COMPLEMENT) {
3070 @from{@from} = (1) x @from;
3071 for ($c = 0; $c < 256; $c++) {
3072 push @newfrom, $c unless $from{$c};
3076 unless ($flags & OPpTRANS_DELETE || !@to) {
3077 pop @to while $#to and $to[$#to] == $to[$#to -1];
3080 $from = collapse(@from);
3081 $to = collapse(@to);
3082 $from .= "-" if $delhyphen;
3083 return ($from, $to);
3088 if ($x == ord "-") {
3095 # XXX This doesn't yet handle all cases correctly either
3097 sub tr_decode_utf8 {
3098 my($swash_hv, $flags) = @_;
3099 my %swash = $swash_hv->ARRAY;
3101 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3102 my $none = $swash{"NONE"}->IV;
3103 my $extra = $none + 1;
3104 my(@from, @delfrom, @to);
3106 foreach $line (split /\n/, $swash{'LIST'}->PV) {
3107 my($min, $max, $result) = split(/\t/, $line);
3114 $result = hex $result;
3115 if ($result == $extra) {
3116 push @delfrom, [$min, $max];
3118 push @from, [$min, $max];
3119 push @to, [$result, $result + $max - $min];
3122 for my $i (0 .. $#from) {
3123 if ($from[$i][0] == ord '-') {
3124 unshift @from, splice(@from, $i, 1);
3125 unshift @to, splice(@to, $i, 1);
3127 } elsif ($from[$i][1] == ord '-') {
3130 unshift @from, ord '-';
3131 unshift @to, ord '-';
3135 for my $i (0 .. $#delfrom) {
3136 if ($delfrom[$i][0] == ord '-') {
3137 push @delfrom, splice(@delfrom, $i, 1);
3139 } elsif ($delfrom[$i][1] == ord '-') {
3141 push @delfrom, ord '-';
3145 if (defined $final and $to[$#to][1] != $final) {
3146 push @to, [$final, $final];
3148 push @from, @delfrom;
3149 if ($flags & OPpTRANS_COMPLEMENT) {
3152 for my $i (0 .. $#from) {
3153 push @newfrom, [$next, $from[$i][0] - 1];
3154 $next = $from[$i][1] + 1;
3157 for my $range (@newfrom) {
3158 if ($range->[0] <= $range->[1]) {
3163 my($from, $to, $diff);
3164 for my $chunk (@from) {
3165 $diff = $chunk->[1] - $chunk->[0];
3167 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3168 } elsif ($diff == 1) {
3169 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3171 $from .= tr_chr($chunk->[0]);
3174 for my $chunk (@to) {
3175 $diff = $chunk->[1] - $chunk->[0];
3177 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3178 } elsif ($diff == 1) {
3179 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3181 $to .= tr_chr($chunk->[0]);
3184 #$final = sprintf("%04x", $final) if defined $final;
3185 #$none = sprintf("%04x", $none) if defined $none;
3186 #$extra = sprintf("%04x", $extra) if defined $extra;
3187 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3188 #print STDERR $swash{'LIST'}->PV;
3189 return (escape_str($from), escape_str($to));
3196 if (class($op) eq "PVOP") {
3197 ($from, $to) = tr_decode_byte($op->pv, $op->private);
3198 } else { # class($op) eq "SVOP"
3199 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3202 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3203 $flags .= "d" if $op->private & OPpTRANS_DELETE;
3204 $to = "" if $from eq $to and $flags eq "";
3205 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3206 return "tr" . double_delim($from, $to) . $flags;
3209 # Like dq(), but different
3213 my $type = $op->name;
3214 if ($type eq "const") {
3215 return '$[' if $op->private & OPpCONST_ARYBASE;
3216 return re_uninterp(escape_str(re_unback($self->const_sv($op)->as_string)));
3217 } elsif ($type eq "concat") {
3218 my $first = $self->re_dq($op->first);
3219 my $last = $self->re_dq($op->last);
3220 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3221 if ($last =~ /^[A-Z\\\^\[\]_?]/) {
3222 $first =~ s/([\$@])\^$/${1}{^}/;
3224 elsif ($last =~ /^[{\[\w]/) {
3225 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
3227 return $first . $last;
3228 } elsif ($type eq "uc") {
3229 return '\U' . $self->re_dq($op->first->sibling) . '\E';
3230 } elsif ($type eq "lc") {
3231 return '\L' . $self->re_dq($op->first->sibling) . '\E';
3232 } elsif ($type eq "ucfirst") {
3233 return '\u' . $self->re_dq($op->first->sibling);
3234 } elsif ($type eq "lcfirst") {
3235 return '\l' . $self->re_dq($op->first->sibling);
3236 } elsif ($type eq "quotemeta") {
3237 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
3238 } elsif ($type eq "join") {
3239 return $self->deparse($op->last, 26); # was join($", @ary)
3241 return $self->deparse($op, 26);
3248 my $kid = $op->first;
3249 $kid = $kid->first if $kid->name eq "regcmaybe";
3250 $kid = $kid->first if $kid->name eq "regcreset";
3251 return $self->re_dq($kid);
3254 # osmic acid -- see osmium tetroxide
3257 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3258 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3259 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3263 my($op, $cx, $name, $delim) = @_;
3264 my $kid = $op->first;
3265 my ($binop, $var, $re) = ("", "", "");
3266 if ($op->flags & OPf_STACKED) {
3268 $var = $self->deparse($kid, 20);
3269 $kid = $kid->sibling;
3272 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3274 $re = $self->deparse($kid, 1);
3277 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3278 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3279 $flags .= "i" if $op->pmflags & PMf_FOLD;
3280 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3281 $flags .= "o" if $op->pmflags & PMf_KEEP;
3282 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3283 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3284 $flags = $matchwords{$flags} if $matchwords{$flags};
3285 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3289 $re = single_delim($name, $delim, $re);
3293 return $self->maybe_parens("$var =~ $re", $cx, 20);
3299 sub pp_match { matchop(@_, "m", "/") }
3300 sub pp_pushre { matchop(@_, "m", "/") }
3301 sub pp_qr { matchop(@_, "qr", "") }
3306 my($kid, @exprs, $ary, $expr);
3308 if ($ {$kid->pmreplroot}) {
3309 $ary = '@' . $self->gv_name($kid->pmreplroot);
3311 for (; !null($kid); $kid = $kid->sibling) {
3312 push @exprs, $self->deparse($kid, 6);
3315 # handle special case of split(), and split(" ") that compiles to /\s+/
3317 if ($kid->flags & OPf_SPECIAL
3318 && $exprs[0] eq '/\\s+/'
3319 && $kid->pmflags & PMf_SKIPWHITE ) {
3323 $expr = "split(" . join(", ", @exprs) . ")";
3325 return $self->maybe_parens("$ary = $expr", $cx, 7);
3331 # oxime -- any of various compounds obtained chiefly by the action of
3332 # hydroxylamine on aldehydes and ketones and characterized by the
3333 # bivalent grouping C=NOH [Webster's Tenth]
3336 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3337 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3338 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3339 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3344 my $kid = $op->first;
3345 my($binop, $var, $re, $repl) = ("", "", "", "");
3346 if ($op->flags & OPf_STACKED) {
3348 $var = $self->deparse($kid, 20);
3349 $kid = $kid->sibling;
3352 if (null($op->pmreplroot)) {
3353 $repl = $self->dq($kid);
3354 $kid = $kid->sibling;
3356 $repl = $op->pmreplroot->first; # skip substcont
3357 while ($repl->name eq "entereval") {
3358 $repl = $repl->first;
3361 if ($op->pmflags & PMf_EVAL) {
3362 $repl = $self->deparse($repl, 0);
3364 $repl = $self->dq($repl);
3368 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3370 $re = $self->deparse($kid, 1);
3372 $flags .= "e" if $op->pmflags & PMf_EVAL;
3373 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3374 $flags .= "i" if $op->pmflags & PMf_FOLD;
3375 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3376 $flags .= "o" if $op->pmflags & PMf_KEEP;
3377 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3378 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3379 $flags = $substwords{$flags} if $substwords{$flags};
3381 return $self->maybe_parens("$var =~ s"
3382 . double_delim($re, $repl) . $flags,
3385 return "s". double_delim($re, $repl) . $flags;
3394 B::Deparse - Perl compiler backend to produce perl code
3398 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3399 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3403 B::Deparse is a backend module for the Perl compiler that generates
3404 perl source code, based on the internal compiled structure that perl
3405 itself creates after parsing a program. The output of B::Deparse won't
3406 be exactly the same as the original source, since perl doesn't keep
3407 track of comments or whitespace, and there isn't a one-to-one
3408 correspondence between perl's syntactical constructions and their
3409 compiled form, but it will often be close. When you use the B<-p>
3410 option, the output also includes parentheses even when they are not
3411 required by precedence, which can make it easy to see if perl is
3412 parsing your expressions the way you intended.
3414 Please note that this module is mainly new and untested code and is
3415 still under development, so it may change in the future.
3419 As with all compiler backend options, these must follow directly after
3420 the '-MO=Deparse', separated by a comma but not any white space.
3426 Add '#line' declarations to the output based on the line and file
3427 locations of the original code.
3431 Print extra parentheses. Without this option, B::Deparse includes
3432 parentheses in its output only when they are needed, based on the
3433 structure of your program. With B<-p>, it uses parentheses (almost)
3434 whenever they would be legal. This can be useful if you are used to
3435 LISP, or if you want to see how perl parses your input. If you say
3437 if ($var & 0x7f == 65) {print "Gimme an A!"}
3438 print ($which ? $a : $b), "\n";
3439 $name = $ENV{USER} or "Bob";
3441 C<B::Deparse,-p> will print
3444 print('Gimme an A!')
3446 (print(($which ? $a : $b)), '???');
3447 (($name = $ENV{'USER'}) or '???')
3449 which probably isn't what you intended (the C<'???'> is a sign that
3450 perl optimized away a constant value).
3454 Expand double-quoted strings into the corresponding combinations of
3455 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3458 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3462 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3463 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3465 Note that the expanded form represents the way perl handles such
3466 constructions internally -- this option actually turns off the reverse
3467 translation that B::Deparse usually does. On the other hand, note that
3468 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3469 of $y into a string before doing the assignment.
3473 Normally, B::Deparse deparses the main code of a program, and all the subs
3474 defined in the same file. To include subs defined in other files, pass the
3475 B<-f> option with the filename. You can pass the B<-f> option several times, to
3476 include more than one secondary file. (Most of the time you don't want to
3477 use it at all.) You can also use this option to include subs which are
3478 defined in the scope of a B<#line> directive with two parameters.
3480 =item B<-s>I<LETTERS>
3482 Tweak the style of B::Deparse's output. The letters should follow
3483 directly after the 's', with no space or punctuation. The following
3484 options are available:
3490 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3507 The default is not to cuddle.
3511 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3515 Use tabs for each 8 columns of indent. The default is to use only spaces.
3516 For instance, if the style options are B<-si4T>, a line that's indented
3517 3 times will be preceded by one tab and four spaces; if the options were
3518 B<-si8T>, the same line would be preceded by three tabs.
3520 =item B<v>I<STRING>B<.>
3522 Print I<STRING> for the value of a constant that can't be determined
3523 because it was optimized away (mnemonic: this happens when a constant
3524 is used in B<v>oid context). The end of the string is marked by a period.
3525 The string should be a valid perl expression, generally a constant.
3526 Note that unless it's a number, it probably needs to be quoted, and on
3527 a command line quotes need to be protected from the shell. Some
3528 conventional values include 0, 1, 42, '', 'foo', and
3529 'Useless use of constant omitted' (which may need to be
3530 B<-sv"'Useless use of constant omitted'.">
3531 or something similar depending on your shell). The default is '???'.
3532 If you're using B::Deparse on a module or other file that's require'd,
3533 you shouldn't use a value that evaluates to false, since the customary
3534 true constant at the end of a module will be in void context when the
3535 file is compiled as a main program.
3541 Expand conventional syntax constructions into equivalent ones that expose
3542 their internal operation. I<LEVEL> should be a digit, with higher values
3543 meaning more expansion. As with B<-q>, this actually involves turning off
3544 special cases in B::Deparse's normal operations.
3546 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3547 while loops with continue blocks; for instance
3549 for ($i = 0; $i < 10; ++$i) {
3562 Note that in a few cases this translation can't be perfectly carried back
3563 into the source code -- if the loop's initializer declares a my variable,
3564 for instance, it won't have the correct scope outside of the loop.
3566 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3567 expressions using C<&&>, C<?:> and C<do {}>; for instance
3569 print 'hi' if $nice;
3581 $nice and print 'hi';
3582 $nice and do { print 'hi' };
3583 $nice ? do { print 'hi' } : do { print 'bye' };
3585 Long sequences of elsifs will turn into nested ternary operators, which
3586 B::Deparse doesn't know how to indent nicely.
3590 =head1 USING B::Deparse AS A MODULE
3595 $deparse = B::Deparse->new("-p", "-sC");
3596 $body = $deparse->coderef2text(\&func);
3597 eval "sub func $body"; # the inverse operation
3601 B::Deparse can also be used on a sub-by-sub basis from other perl
3606 $deparse = B::Deparse->new(OPTIONS)
3608 Create an object to store the state of a deparsing operation and any
3609 options. The options are the same as those that can be given on the
3610 command line (see L</OPTIONS>); options that are separated by commas
3611 after B<-MO=Deparse> should be given as separate strings. Some
3612 options, like B<-u>, don't make sense for a single subroutine, so
3615 =head2 ambient_pragmas
3617 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3619 The compilation of a subroutine can be affected by a few compiler
3620 directives, B<pragmas>. These are:
3634 Assigning to the special variable $[
3654 Ordinarily, if you use B::Deparse on a subroutine which has
3655 been compiled in the presence of one or more of these pragmas,
3656 the output will include statements to turn on the appropriate
3657 directives. So if you then compile the code returned by coderef2text,
3658 it will behave the same way as the subroutine which you deparsed.
3660 However, you may know that you intend to use the results in a
3661 particular context, where some pragmas are already in scope. In
3662 this case, you use the B<ambient_pragmas> method to describe the
3663 assumptions you wish to make.
3665 The parameters it accepts are:
3671 Takes a string, possibly containing several values separated
3672 by whitespace. The special values "all" and "none" mean what you'd
3675 $deparse->ambient_pragmas(strict => 'subs refs');
3679 Takes a number, the value of the array base $[.
3687 If the value is true, then the appropriate pragma is assumed to
3688 be in the ambient scope, otherwise not.
3692 Takes a string, possibly containing a whitespace-separated list of
3693 values. The values "all" and "none" are special. It's also permissible
3694 to pass an array reference here.
3696 $deparser->ambient_pragmas(re => 'eval');
3701 Takes a string, possibly containing a whitespace-separated list of
3702 values. The values "all" and "none" are special, again. It's also
3703 permissible to pass an array reference here.
3705 $deparser->ambient_pragmas(warnings => [qw[void io]]);
3707 If one of the values is the string "FATAL", then all the warnings
3708 in that list will be considered fatal, just as with the B<warnings>
3709 pragma itself. Should you need to specify that some warnings are
3710 fatal, and others are merely enabled, you can pass the B<warnings>
3713 $deparser->ambient_pragmas(
3715 warnings => [FATAL => qw/void io/],
3718 See L<perllexwarn> for more information about lexical warnings.
3724 These two parameters are used to specify the ambient pragmas in
3725 the format used by the special variables $^H and ${^WARNING_BITS}.
3727 They exist principally so that you can write code like:
3729 { my ($hint_bits, $warning_bits);
3730 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3731 $deparser->ambient_pragmas (
3732 hint_bits => $hint_bits,
3733 warning_bits => $warning_bits,
3737 which specifies that the ambient pragmas are exactly those which
3738 are in scope at the point of calling.
3744 $body = $deparse->coderef2text(\&func)
3745 $body = $deparse->coderef2text(sub ($$) { ... })
3747 Return source code for the body of a subroutine (a block, optionally
3748 preceded by a prototype in parens), given a reference to the
3749 sub. Because a subroutine can have no names, or more than one name,
3750 this method doesn't return a complete subroutine definition -- if you
3751 want to eval the result, you should prepend "sub subname ", or "sub "
3752 for an anonymous function constructor. Unless the sub was defined in
3753 the main:: package, the code will include a package declaration.
3757 See the 'to do' list at the beginning of the module file.
3761 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3762 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3763 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3764 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.