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
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);
24 # Changes between 0.50 and 0.51:
25 # - fixed nulled leave with live enter in sort { }
26 # - fixed reference constants (\"str")
27 # - handle empty programs gracefully
28 # - handle infinte loops (for (;;) {}, while (1) {})
29 # - differentiate between `for my $x ...' and `my $x; for $x ...'
30 # - various minor cleanups
31 # - moved globals into an object
32 # - added `-u', like B::C
33 # - package declarations using cop_stash
34 # - subs, formats and code sorted by cop_seq
35 # Changes between 0.51 and 0.52:
36 # - added pp_threadsv (special variables under USE_THREADS)
37 # - added documentation
38 # Changes between 0.52 and 0.53:
39 # - many changes adding precedence contexts and associativity
40 # - added `-p' and `-s' output style options
41 # - various other minor fixes
42 # Changes between 0.53 and 0.54:
43 # - added support for new `for (1..100)' optimization,
45 # Changes between 0.54 and 0.55:
46 # - added support for new qr// construct
47 # - added support for new pp_regcreset OP
48 # Changes between 0.55 and 0.56:
49 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
50 # - fixed $# on non-lexicals broken in last big rewrite
51 # - added temporary fix for change in opcode of OP_STRINGIFY
52 # - fixed problem in 0.54's for() patch in `for (@ary)'
53 # - fixed precedence in conditional of ?:
54 # - tweaked list paren elimination in `my($x) = @_'
55 # - made continue-block detection trickier wrt. null ops
56 # - fixed various prototype problems in pp_entersub
57 # - added support for sub prototypes that never get GVs
58 # - added unquoting for special filehandle first arg in truncate
59 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
60 # - added semicolons at the ends of blocks
61 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
62 # Changes between 0.56 and 0.561:
63 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
64 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
65 # Changes between 0.561 and 0.57:
66 # - stylistic changes to symbolic constant stuff
67 # - handled scope in s///e replacement code
68 # - added unquote option for expanding "" into concats, etc.
69 # - split method and proto parts of pp_entersub into separate functions
70 # - various minor cleanups
72 # - added parens in \&foo (patch by Albert Dvornik)
73 # Changes between 0.57 and 0.58:
74 # - fixed `0' statements that weren't being printed
75 # - added methods for use from other programs
76 # (based on patches from James Duncan and Hugo van der Sanden)
77 # - added -si and -sT to control indenting (also based on a patch from Hugo)
78 # - added -sv to print something else instead of '???'
79 # - preliminary version of utf8 tr/// handling
81 # - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
82 # - added support for Hugo's new OP_SETSTATE (like nextstate)
83 # Changes between 0.58 and 0.59
84 # - added support for Chip's OP_METHOD_NAMED
85 # - added support for Ilya's OPpTARGET_MY optimization
86 # - elided arrows before `()' subscripts when possible
87 # Changes between 0.59 and 0.60
88 # - support for method attribues was added
89 # - some warnings fixed
90 # - separate recognition of constant subs
91 # - rewrote continue block handling, now recoginizing for loops
92 # - added more control of expanding control structures
95 # - finish tr/// changes
96 # - add option for even more parens (generalize \&foo change)
97 # - left/right context
98 # - recognize `use utf8', `use integer', etc
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 # - include values of variables (e.g. set in BEGIN)
110 # - coordinate with Data::Dumper (both directions? see previous)
111 # - version using op_next instead of op_first/sibling?
112 # - avoid string copies (pass arrays, one big join?)
114 # - -uPackage:: descend recursively?
118 # Tests that will always fail:
119 # comp/redef.t -- all (redefinition happens at compile time)
121 # Object fields (were globals):
124 # (local($a), local($b)) and local($a, $b) have the same internal
125 # representation but the short form looks better. We notice we can
126 # use a large-scale local when checking the list, but need to prevent
127 # individual locals too. This hash holds the addresses of OPs that
128 # have already had their local-ness accounted for. The same thing
132 # CV for current sub (or main program) being deparsed
135 # name of the current package for deparsed code
138 # array of [cop_seq, GV, is_format?] for subs and formats we still
142 # as above, but [name, prototype] for subs that never got a GV
144 # subs_done, forms_done:
145 # keys are addresses of GVs for subs and formats we've already
146 # deparsed (or at least put into subs_todo)
149 # keys are names of subs for which we've printed declarations.
150 # That means we can omit parentheses from the arguments.
155 # cuddle: ` ' or `\n', depending on -sC
160 # A little explanation of how precedence contexts and associativity
163 # deparse() calls each per-op subroutine with an argument $cx (short
164 # for context, but not the same as the cx* in the perl core), which is
165 # a number describing the op's parents in terms of precedence, whether
166 # they're inside an expression or at statement level, etc. (see
167 # chart below). When ops with children call deparse on them, they pass
168 # along their precedence. Fractional values are used to implement
169 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
170 # parentheses hacks. The major disadvantage of this scheme is that
171 # it doesn't know about right sides and left sides, so say if you
172 # assign a listop to a variable, it can't tell it's allowed to leave
173 # the parens off the listop.
176 # 26 [TODO] inside interpolation context ("")
177 # 25 left terms and list operators (leftward)
181 # 21 right ! ~ \ and unary + and -
186 # 16 nonassoc named unary operators
187 # 15 nonassoc < > <= >= lt gt le ge
188 # 14 nonassoc == != <=> eq ne cmp
195 # 7 right = += -= *= etc.
197 # 5 nonassoc list operators (rightward)
201 # 1 statement modifiers
204 # Nonprinting characters with special meaning:
205 # \cS - steal parens (see maybe_parens_unop)
206 # \n - newline and indent
207 # \t - increase indent
208 # \b - decrease indent (`outdent')
209 # \f - flush left (no indent)
210 # \cK - kill following semicolon, if any
214 return class($op) eq "NULL";
219 my($gv, $cv, $is_form) = @_;
221 if (!null($cv->START) and is_state($cv->START)) {
222 $seq = $cv->START->cop_seq;
226 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
231 my $ent = shift @{$self->{'subs_todo'}};
232 my $name = $self->gv_name($ent->[1]);
234 return "format $name =\n"
235 . $self->deparse_format($ent->[1]->FORM). "\n";
237 $self->{'subs_declared'}{$name} = 1;
238 return "sub $name " . $self->deparse_sub($ent->[1]->CV);
245 if ($op->flags & OPf_KIDS) {
247 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
248 walk_tree($kid, $sub);
257 $op = shift if null $op;
258 return if !$op or null $op;
261 if ($op->name eq "gv") {
262 my $gv = $self->gv_or_padgv($op);
263 if ($op->next->name eq "entersub") {
264 return if $self->{'subs_done'}{$$gv}++;
265 return if class($gv->CV) eq "SPECIAL";
266 $self->todo($gv, $gv->CV, 0);
267 $self->walk_sub($gv->CV);
268 } elsif ($op->next->name eq "enterwrite"
269 or ($op->next->name eq "rv2gv"
270 and $op->next->next->name eq "enterwrite")) {
271 return if $self->{'forms_done'}{$$gv}++;
272 return if class($gv->FORM) eq "SPECIAL";
273 $self->todo($gv, $gv->FORM, 1);
274 $self->walk_sub($gv->FORM);
284 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
285 if ($pack eq "main") {
288 $pack = $pack . "::";
291 while (($key, $val) = each %stash) {
292 my $class = class($val);
293 if ($class eq "PV") {
295 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
296 } elsif ($class eq "IV") {
298 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
299 } elsif ($class eq "GV") {
300 if (class($val->CV) ne "SPECIAL") {
301 next if $self->{'subs_done'}{$$val}++;
302 $self->todo($val, $val->CV, 0);
303 $self->walk_sub($val->CV);
305 if (class($val->FORM) ne "SPECIAL") {
306 next if $self->{'forms_done'}{$$val}++;
307 $self->todo($val, $val->FORM, 1);
308 $self->walk_sub($val->FORM);
318 foreach $ar (@{$self->{'protos_todo'}}) {
319 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
320 push @ret, "sub " . $ar->[0] . "$proto;\n";
322 delete $self->{'protos_todo'};
330 while (length($opt = substr($opts, 0, 1))) {
332 $self->{'cuddle'} = " ";
333 $opts = substr($opts, 1);
334 } elsif ($opt eq "i") {
335 $opts =~ s/^i(\d+)//;
336 $self->{'indent_size'} = $1;
337 } elsif ($opt eq "T") {
338 $self->{'use_tabs'} = 1;
339 $opts = substr($opts, 1);
340 } elsif ($opt eq "v") {
341 $opts =~ s/^v([^.]*)(.|$)//;
342 $self->{'ex_const'} = $1;
349 my $self = bless {}, $class;
350 $self->{'subs_todo'} = [];
351 $self->{'curstash'} = "main";
352 $self->{'cuddle'} = "\n";
353 $self->{'indent_size'} = 4;
354 $self->{'use_tabs'} = 0;
355 $self->{'expand'} = 0;
356 $self->{'unquote'} = 0;
357 $self->{'linenums'} = 0;
358 $self->{'parens'} = 0;
359 $self->{'ex_const'} = "'???'";
361 $self->{'ambient_arybase'} = 0;
362 $self->{'ambient_warnings'} = "\0"x12;
363 $self->{'ambient_hints'} = 0;
366 while (my $arg = shift @_) {
367 if (substr($arg, 0, 2) eq "-u") {
368 $self->stash_subs(substr($arg, 2));
369 } elsif ($arg eq "-p") {
370 $self->{'parens'} = 1;
371 } elsif ($arg eq "-l") {
372 $self->{'linenums'} = 1;
373 } elsif ($arg eq "-q") {
374 $self->{'unquote'} = 1;
375 } elsif (substr($arg, 0, 2) eq "-s") {
376 $self->style_opts(substr $arg, 2);
377 } elsif ($arg =~ /^-x(\d)$/) {
378 $self->{'expand'} = $1;
384 # Initialise the contextual information, either from
385 # defaults provided with the ambient_pragmas method,
386 # or from perl's own defaults otherwise.
390 $self->{'arybase'} = $self->{'ambient_arybase'};
391 $self->{'warnings'} = $self->{'ambient_warnings'};
392 $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
394 # also a convenient place to clear out subs_declared
395 delete $self->{'subs_declared'};
401 my $self = B::Deparse->new(@args);
402 $self->stash_subs("main");
403 $self->{'curcv'} = main_cv;
404 $self->walk_sub(main_cv, main_start);
405 print $self->print_protos;
406 @{$self->{'subs_todo'}} =
407 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
408 print $self->indent($self->deparse(main_root, 0)), "\n"
409 unless null main_root;
411 while (scalar(@{$self->{'subs_todo'}})) {
412 push @text, $self->next_todo;
414 print $self->indent(join("", @text)), "\n" if @text;
421 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
424 return $self->indent($self->deparse_sub(svref_2object($sub)));
427 sub ambient_pragmas {
429 my ($arybase, $hint_bits, $warning_bits) = (0, 0, "\0"x12);
435 if ($name eq 'strict') {
438 if ($val eq 'none') {
439 $hint_bits &= ~strict::bits(qw/refs subs vars/);
445 @names = qw/refs subs vars/;
451 @names = split' ', $val;
453 $hint_bits |= strict::bits(@names);
456 elsif ($name eq '$[') {
460 elsif ($name eq 'integer'
462 || $name eq 'utf8') {
465 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
468 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
472 elsif ($name eq 're') {
474 if ($val eq 'none') {
475 $hint_bits &= ~re::bits(qw/taint eval asciirange/);
481 @names = qw/taint eval asciirange/;
487 @names = split' ',$val;
489 $hint_bits |= re::bits(@names);
492 elsif ($name eq 'warnings') {
494 if ($val eq 'none') {
495 $warning_bits = "\0"x12;
504 @names = split/\s+/, $val;
507 $warning_bits |= warnings::bits(@names);
510 elsif ($name eq 'warning_bits') {
511 $warning_bits = $val;
514 elsif ($name eq 'hint_bits') {
519 croak "Unknown pragma type: $name";
523 croak "The ambient_pragmas method expects an even number of args";
526 $self->{'ambient_arybase'} = $arybase;
527 $self->{'ambient_warnings'} = $warning_bits;
528 $self->{'ambient_hints'} = $hint_bits;
534 # cluck if class($op) eq "NULL";
536 # return $self->$ {\("pp_" . $op->name)}($op, $cx);
538 Carp::confess() unless defined $op;
539 my $meth = "pp_" . $op->name;
540 return $self->$meth($op, $cx);
546 my @lines = split(/\n/, $txt);
551 my $cmd = substr($line, 0, 1);
552 if ($cmd eq "\t" or $cmd eq "\b") {
553 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
554 if ($self->{'use_tabs'}) {
555 $leader = "\t" x ($level / 8) . " " x ($level % 8);
557 $leader = " " x $level;
559 $line = substr($line, 1);
561 if (substr($line, 0, 1) eq "\f") {
562 $line = substr($line, 1); # no indent
564 $line = $leader . $line;
568 return join("\n", @lines);
575 if ($cv->FLAGS & SVf_POK) {
576 $proto = "(". $cv->PV . ") ";
578 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
580 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
581 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
582 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
585 local($self->{'curcv'}) = $cv;
586 local(@$self{qw'curstash warnings hints'})
587 = @$self{qw'curstash warnings hints'};
588 if (not null $cv->ROOT) {
590 return $proto . "{\n\t" .
591 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
593 my $sv = $cv->const_sv;
595 # uh-oh. inlinable sub... format it differently
596 return $proto . "{ " . const($sv) . " }\n";
598 return $proto . "{}\n";
606 local($self->{'curcv'}) = $form;
607 local(@$self{qw'curstash warnings hints'})
608 = @$self{'curstash warnings hints'};
609 my $op = $form->ROOT;
611 $op = $op->first->first; # skip leavewrite, lineseq
612 while (not null $op) {
613 $op = $op->sibling; # skip nextstate
615 $kid = $op->first->sibling; # skip pushmark
616 push @text, $self->const_sv($kid)->PV;
617 $kid = $kid->sibling;
618 for (; not null $kid; $kid = $kid->sibling) {
619 push @exprs, $self->deparse($kid, 0);
621 push @text, join(", ", @exprs)."\n" if @exprs;
624 return join("", @text) . ".";
629 return $op->name eq "leave" || $op->name eq "scope"
630 || $op->name eq "lineseq"
631 || ($op->name eq "null" && class($op) eq "UNOP"
632 && (is_scope($op->first) || $op->first->name eq "enter"));
636 my $name = $_[0]->name;
637 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
640 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
642 return (!null($op) and null($op->sibling)
643 and $op->name eq "null" and class($op) eq "UNOP"
644 and (($op->first->name =~ /^(and|or)$/
645 and $op->first->first->sibling->name eq "lineseq")
646 or ($op->first->name eq "lineseq"
647 and not null $op->first->first->sibling
648 and $op->first->first->sibling->name eq "unstack")
654 return ($op->name eq "rv2sv" or
655 $op->name eq "padsv" or
656 $op->name eq "gv" or # only in array/hash constructs
657 $op->flags & OPf_KIDS && !null($op->first)
658 && $op->first->name eq "gvsv");
663 my($text, $cx, $prec) = @_;
664 if ($prec < $cx # unary ops nest just fine
665 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
666 or $self->{'parens'})
669 # In a unop, let parent reuse our parens; see maybe_parens_unop
670 $text = "\cS" . $text if $cx == 16;
677 # same as above, but get around the `if it looks like a function' rule
678 sub maybe_parens_unop {
680 my($name, $kid, $cx) = @_;
681 if ($cx > 16 or $self->{'parens'}) {
682 return "$name(" . $self->deparse($kid, 1) . ")";
684 $kid = $self->deparse($kid, 16);
685 if (substr($kid, 0, 1) eq "\cS") {
687 return $name . substr($kid, 1);
688 } elsif (substr($kid, 0, 1) eq "(") {
689 # avoid looks-like-a-function trap with extra parens
690 # (`+' can lead to ambiguities)
691 return "$name(" . $kid . ")";
698 sub maybe_parens_func {
700 my($func, $text, $cx, $prec) = @_;
701 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
702 return "$func($text)";
704 return "$func $text";
710 my($op, $cx, $text) = @_;
711 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
712 if (want_scalar($op)) {
713 return "local $text";
715 return $self->maybe_parens_func("local", $text, $cx, 16);
724 my($op, $cx, $func, @args) = @_;
725 if ($op->private & OPpTARGET_MY) {
726 my $var = $self->padname($op->targ);
727 my $val = $func->($self, $op, 7, @args);
728 return $self->maybe_parens("$var = $val", $cx, 7);
730 return $func->($self, $op, $cx, @args);
737 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
742 my($op, $cx, $text) = @_;
743 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
744 if (want_scalar($op)) {
747 return $self->maybe_parens_func("my", $text, $cx, 16);
754 # The following OPs don't have functions:
756 # pp_padany -- does not exist after parsing
757 # pp_rcatline -- does not exist
759 sub pp_enter { # see also leave
760 cluck "unexpected OP_ENTER";
764 sub pp_pushmark { # see also list
765 cluck "unexpected OP_PUSHMARK";
769 sub pp_leavesub { # see also deparse_sub
770 cluck "unexpected OP_LEAVESUB";
774 sub pp_leavewrite { # see also deparse_format
775 cluck "unexpected OP_LEAVEWRITE";
779 sub pp_method { # see also entersub
780 cluck "unexpected OP_METHOD";
784 sub pp_regcmaybe { # see also regcomp
785 cluck "unexpected OP_REGCMAYBE";
789 sub pp_regcreset { # see also regcomp
790 cluck "unexpected OP_REGCRESET";
794 sub pp_substcont { # see also subst
795 cluck "unexpected OP_SUBSTCONT";
799 sub pp_grepstart { # see also grepwhile
800 cluck "unexpected OP_GREPSTART";
804 sub pp_mapstart { # see also mapwhile
805 cluck "unexpected OP_MAPSTART";
809 sub pp_flip { # see also flop
810 cluck "unexpected OP_FLIP";
814 sub pp_iter { # see also leaveloop
815 cluck "unexpected OP_ITER";
819 sub pp_enteriter { # see also leaveloop
820 cluck "unexpected OP_ENTERITER";
824 sub pp_enterloop { # see also leaveloop
825 cluck "unexpected OP_ENTERLOOP";
829 sub pp_leaveeval { # see also entereval
830 cluck "unexpected OP_LEAVEEVAL";
834 sub pp_entertry { # see also leavetry
835 cluck "unexpected OP_ENTERTRY";
843 for (my $i = 0; $i < @ops; $i++) {
845 if (is_state $ops[$i]) {
846 $expr = $self->deparse($ops[$i], 0);
850 if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
851 $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
853 push @exprs, $expr . $self->for_loop($ops[$i], 0);
857 $expr .= $self->deparse($ops[$i], 0);
858 push @exprs, $expr if length $expr;
860 for(@exprs[0..@exprs-1]) { s/;\n\z// }
861 return join(";\n", @exprs);
865 my($real_block, $self, $op, $cx) = @_;
869 local(@$self{qw'curstash warnings hints'})
870 = @$self{qw'curstash warnings hints'} if $real_block;
872 $kid = $op->first->sibling; # skip enter
873 if (is_miniwhile($kid)) {
874 my $top = $kid->first;
875 my $name = $top->name;
876 if ($name eq "and") {
878 } elsif ($name eq "or") {
880 } else { # no conditional -> while 1 or until 0
881 return $self->deparse($top->first, 1) . " while 1";
883 my $cond = $top->first;
884 my $body = $cond->sibling->first; # skip lineseq
885 $cond = $self->deparse($cond, 1);
886 $body = $self->deparse($body, 1);
887 return "$body $name $cond";
892 for (; !null($kid); $kid = $kid->sibling) {
895 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
896 return "do { " . $self->lineseq(@kids) . " }";
898 my $lineseq = $self->lineseq(@kids);
899 return (length ($lineseq) ? "$lineseq;" : "");
903 sub pp_scope { scopeop(0, @_); }
904 sub pp_lineseq { scopeop(0, @_); }
905 sub pp_leave { scopeop(1, @_); }
907 # The BEGIN {} is used here because otherwise this code isn't executed
908 # when you run B::Deparse on itself.
910 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
911 "ENV", "ARGV", "ARGVOUT", "_"); }
916 my $stash = $gv->STASH->NAME;
917 my $name = $gv->SAFENAME;
918 if ($stash eq $self->{'curstash'} or $globalnames{$name}
919 or $name =~ /^[^A-Za-z_]/)
923 $stash = $stash . "::";
925 if ($name =~ /^\^../) {
926 $name = "{$name}"; # ${^WARNING_BITS} etc
928 return $stash . $name;
931 # Notice how subs and formats are inserted between statements here;
932 # also $[ assignments and pragmas.
937 @text = $op->label . ": " if $op->label;
938 my $seq = $op->cop_seq;
939 while (scalar(@{$self->{'subs_todo'}})
940 and $seq >= $self->{'subs_todo'}[0][0]) {
941 push @text, $self->next_todo;
943 my $stash = $op->stashpv;
944 if ($stash ne $self->{'curstash'}) {
945 push @text, "package $stash;\n";
946 $self->{'curstash'} = $stash;
948 if ($self->{'linenums'}) {
949 push @text, "\f#line " . $op->line .
950 ' "' . $op->file, qq'"\n';
953 if ($self->{'arybase'} != $op->arybase) {
954 push @text, '$[ = '. $op->arybase .";\n";
955 $self->{'arybase'} = $op->arybase;
958 my $warnings = $op->warnings;
960 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
961 $warning_bits = $warnings::Bits{"all"};
963 elsif ($warnings->isa("B::SPECIAL")) {
964 $warning_bits = "\0"x12;
967 $warning_bits = $warnings->PV;
970 if ($self->{'warnings'} ne $warning_bits) {
971 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
972 $self->{'warnings'} = $warning_bits;
975 if ($self->{'hints'} != $op->private) {
976 push @text, declare_hints($self->{'hints'}, $op->private);
977 $self->{'hints'} = $op->private;
980 return join("", @text);
983 sub declare_warnings {
984 my ($from, $to) = @_;
986 if ($to eq warnings::bits("all")) {
987 return "use warnings;\n";
989 elsif ($to eq "\0"x12) {
990 return "no warnings;\n";
992 return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
996 my ($from, $to) = @_;
998 return sprintf "BEGIN {\$^H &= ~0xFF; \$^H |= %x}\n", $bits;
1001 sub pp_dbstate { pp_nextstate(@_) }
1002 sub pp_setstate { pp_nextstate(@_) }
1004 sub pp_unstack { return "" } # see also leaveloop
1008 my($op, $cx, $name) = @_;
1012 sub pp_stub { baseop(@_, "()") }
1013 sub pp_wantarray { baseop(@_, "wantarray") }
1014 sub pp_fork { baseop(@_, "fork") }
1015 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1016 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1017 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1018 sub pp_tms { baseop(@_, "times") }
1019 sub pp_ghostent { baseop(@_, "gethostent") }
1020 sub pp_gnetent { baseop(@_, "getnetent") }
1021 sub pp_gprotoent { baseop(@_, "getprotoent") }
1022 sub pp_gservent { baseop(@_, "getservent") }
1023 sub pp_ehostent { baseop(@_, "endhostent") }
1024 sub pp_enetent { baseop(@_, "endnetent") }
1025 sub pp_eprotoent { baseop(@_, "endprotoent") }
1026 sub pp_eservent { baseop(@_, "endservent") }
1027 sub pp_gpwent { baseop(@_, "getpwent") }
1028 sub pp_spwent { baseop(@_, "setpwent") }
1029 sub pp_epwent { baseop(@_, "endpwent") }
1030 sub pp_ggrent { baseop(@_, "getgrent") }
1031 sub pp_sgrent { baseop(@_, "setgrent") }
1032 sub pp_egrent { baseop(@_, "endgrent") }
1033 sub pp_getlogin { baseop(@_, "getlogin") }
1035 sub POSTFIX () { 1 }
1037 # I couldn't think of a good short name, but this is the category of
1038 # symbolic unary operators with interesting precedence
1042 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1043 my $kid = $op->first;
1044 $kid = $self->deparse($kid, $prec);
1045 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1049 sub pp_preinc { pfixop(@_, "++", 23) }
1050 sub pp_predec { pfixop(@_, "--", 23) }
1051 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1052 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1053 sub pp_i_preinc { pfixop(@_, "++", 23) }
1054 sub pp_i_predec { pfixop(@_, "--", 23) }
1055 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1056 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1057 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1059 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1063 if ($op->first->name =~ /^(i_)?negate$/) {
1065 $self->pfixop($op, $cx, "-", 21.5);
1067 $self->pfixop($op, $cx, "-", 21);
1070 sub pp_i_negate { pp_negate(@_) }
1076 $self->pfixop($op, $cx, "not ", 4);
1078 $self->pfixop($op, $cx, "!", 21);
1084 my($op, $cx, $name) = @_;
1086 if ($op->flags & OPf_KIDS) {
1088 return $self->maybe_parens_unop($name, $kid, $cx);
1090 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1094 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1095 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1096 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1097 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1098 sub pp_defined { unop(@_, "defined") }
1099 sub pp_undef { unop(@_, "undef") }
1100 sub pp_study { unop(@_, "study") }
1101 sub pp_ref { unop(@_, "ref") }
1102 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1104 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1105 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1106 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1107 sub pp_srand { unop(@_, "srand") }
1108 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1109 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1110 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1111 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1112 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1113 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1114 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1116 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1117 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1118 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1120 sub pp_each { unop(@_, "each") }
1121 sub pp_values { unop(@_, "values") }
1122 sub pp_keys { unop(@_, "keys") }
1123 sub pp_pop { unop(@_, "pop") }
1124 sub pp_shift { unop(@_, "shift") }
1126 sub pp_caller { unop(@_, "caller") }
1127 sub pp_reset { unop(@_, "reset") }
1128 sub pp_exit { unop(@_, "exit") }
1129 sub pp_prototype { unop(@_, "prototype") }
1131 sub pp_close { unop(@_, "close") }
1132 sub pp_fileno { unop(@_, "fileno") }
1133 sub pp_umask { unop(@_, "umask") }
1134 sub pp_untie { unop(@_, "untie") }
1135 sub pp_tied { unop(@_, "tied") }
1136 sub pp_dbmclose { unop(@_, "dbmclose") }
1137 sub pp_getc { unop(@_, "getc") }
1138 sub pp_eof { unop(@_, "eof") }
1139 sub pp_tell { unop(@_, "tell") }
1140 sub pp_getsockname { unop(@_, "getsockname") }
1141 sub pp_getpeername { unop(@_, "getpeername") }
1143 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1144 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1145 sub pp_readlink { unop(@_, "readlink") }
1146 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1147 sub pp_readdir { unop(@_, "readdir") }
1148 sub pp_telldir { unop(@_, "telldir") }
1149 sub pp_rewinddir { unop(@_, "rewinddir") }
1150 sub pp_closedir { unop(@_, "closedir") }
1151 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1152 sub pp_localtime { unop(@_, "localtime") }
1153 sub pp_gmtime { unop(@_, "gmtime") }
1154 sub pp_alarm { unop(@_, "alarm") }
1155 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1157 sub pp_dofile { unop(@_, "do") }
1158 sub pp_entereval { unop(@_, "eval") }
1160 sub pp_ghbyname { unop(@_, "gethostbyname") }
1161 sub pp_gnbyname { unop(@_, "getnetbyname") }
1162 sub pp_gpbyname { unop(@_, "getprotobyname") }
1163 sub pp_shostent { unop(@_, "sethostent") }
1164 sub pp_snetent { unop(@_, "setnetent") }
1165 sub pp_sprotoent { unop(@_, "setprotoent") }
1166 sub pp_sservent { unop(@_, "setservent") }
1167 sub pp_gpwnam { unop(@_, "getpwnam") }
1168 sub pp_gpwuid { unop(@_, "getpwuid") }
1169 sub pp_ggrnam { unop(@_, "getgrnam") }
1170 sub pp_ggrgid { unop(@_, "getgrgid") }
1172 sub pp_lock { unop(@_, "lock") }
1177 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1185 if ($op->private & OPpSLICE) {
1186 return $self->maybe_parens_func("delete",
1187 $self->pp_hslice($op->first, 16),
1190 return $self->maybe_parens_func("delete",
1191 $self->pp_helem($op->first, 16),
1199 if (class($op) eq "UNOP" and $op->first->name eq "const"
1200 and $op->first->private & OPpCONST_BARE)
1202 my $name = $self->const_sv($op->first)->PV;
1205 return "require($name)";
1207 $self->unop($op, $cx, "require");
1214 my $kid = $op->first;
1215 if (not null $kid->sibling) {
1216 # XXX Was a here-doc
1217 return $self->dquote($op);
1219 $self->unop(@_, "scalar");
1226 #cluck "curcv was undef" unless $self->{curcv};
1227 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1233 my $kid = $op->first;
1234 if ($kid->name eq "null") {
1236 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1237 my($pre, $post) = @{{"anonlist" => ["[","]"],
1238 "anonhash" => ["{","}"]}->{$kid->name}};
1240 $kid = $kid->first->sibling; # skip pushmark
1241 for (; !null($kid); $kid = $kid->sibling) {
1242 $expr = $self->deparse($kid, 6);
1245 return $pre . join(", ", @exprs) . $post;
1246 } elsif (!null($kid->sibling) and
1247 $kid->sibling->name eq "anoncode") {
1249 $self->deparse_sub($self->padval($kid->sibling->targ));
1250 } elsif ($kid->name eq "pushmark") {
1251 my $sib_name = $kid->sibling->name;
1252 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1253 and not $kid->sibling->flags & OPf_REF)
1255 # The @a in \(@a) isn't in ref context, but only when the
1257 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1258 } elsif ($sib_name eq 'entersub') {
1259 my $text = $self->deparse($kid->sibling, 1);
1260 # Always show parens for \(&func()), but only with -p otherwise
1261 $text = "($text)" if $self->{'parens'}
1262 or $kid->sibling->private & OPpENTERSUB_AMPER;
1267 $self->pfixop($op, $cx, "\\", 20);
1270 sub pp_srefgen { pp_refgen(@_) }
1275 my $kid = $op->first;
1276 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1277 return "<" . $self->deparse($kid, 1) . ">";
1280 # Unary operators that can occur as pseudo-listops inside double quotes
1283 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1285 if ($op->flags & OPf_KIDS) {
1287 # If there's more than one kid, the first is an ex-pushmark.
1288 $kid = $kid->sibling if not null $kid->sibling;
1289 return $self->maybe_parens_unop($name, $kid, $cx);
1291 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1295 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1296 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1297 sub pp_uc { dq_unop(@_, "uc") }
1298 sub pp_lc { dq_unop(@_, "lc") }
1299 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1303 my ($op, $cx, $name) = @_;
1304 if (class($op) eq "PVOP") {
1305 return "$name " . $op->pv;
1306 } elsif (class($op) eq "OP") {
1308 } elsif (class($op) eq "UNOP") {
1309 # Note -- loop exits are actually exempt from the
1310 # looks-like-a-func rule, but a few extra parens won't hurt
1311 return $self->maybe_parens_unop($name, $op->first, $cx);
1315 sub pp_last { loopex(@_, "last") }
1316 sub pp_next { loopex(@_, "next") }
1317 sub pp_redo { loopex(@_, "redo") }
1318 sub pp_goto { loopex(@_, "goto") }
1319 sub pp_dump { loopex(@_, "dump") }
1323 my($op, $cx, $name) = @_;
1324 if (class($op) eq "UNOP") {
1325 # Genuine `-X' filetests are exempt from the LLAFR, but not
1326 # l?stat(); for the sake of clarity, give'em all parens
1327 return $self->maybe_parens_unop($name, $op->first, $cx);
1328 } elsif (class($op) eq "SVOP") {
1329 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1330 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1335 sub pp_lstat { ftst(@_, "lstat") }
1336 sub pp_stat { ftst(@_, "stat") }
1337 sub pp_ftrread { ftst(@_, "-R") }
1338 sub pp_ftrwrite { ftst(@_, "-W") }
1339 sub pp_ftrexec { ftst(@_, "-X") }
1340 sub pp_fteread { ftst(@_, "-r") }
1341 sub pp_ftewrite { ftst(@_, "-r") }
1342 sub pp_fteexec { ftst(@_, "-r") }
1343 sub pp_ftis { ftst(@_, "-e") }
1344 sub pp_fteowned { ftst(@_, "-O") }
1345 sub pp_ftrowned { ftst(@_, "-o") }
1346 sub pp_ftzero { ftst(@_, "-z") }
1347 sub pp_ftsize { ftst(@_, "-s") }
1348 sub pp_ftmtime { ftst(@_, "-M") }
1349 sub pp_ftatime { ftst(@_, "-A") }
1350 sub pp_ftctime { ftst(@_, "-C") }
1351 sub pp_ftsock { ftst(@_, "-S") }
1352 sub pp_ftchr { ftst(@_, "-c") }
1353 sub pp_ftblk { ftst(@_, "-b") }
1354 sub pp_ftfile { ftst(@_, "-f") }
1355 sub pp_ftdir { ftst(@_, "-d") }
1356 sub pp_ftpipe { ftst(@_, "-p") }
1357 sub pp_ftlink { ftst(@_, "-l") }
1358 sub pp_ftsuid { ftst(@_, "-u") }
1359 sub pp_ftsgid { ftst(@_, "-g") }
1360 sub pp_ftsvtx { ftst(@_, "-k") }
1361 sub pp_fttty { ftst(@_, "-t") }
1362 sub pp_fttext { ftst(@_, "-T") }
1363 sub pp_ftbinary { ftst(@_, "-B") }
1365 sub SWAP_CHILDREN () { 1 }
1366 sub ASSIGN () { 2 } # has OP= variant
1372 my $name = $op->name;
1373 if ($name eq "concat" and $op->first->name eq "concat") {
1374 # avoid spurious `=' -- see comment in pp_concat
1377 if ($name eq "null" and class($op) eq "UNOP"
1378 and $op->first->name =~ /^(and|x?or)$/
1379 and null $op->first->sibling)
1381 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1382 # with a null that's used as the common end point of the two
1383 # flows of control. For precedence purposes, ignore it.
1384 # (COND_EXPRs have these too, but we don't bother with
1385 # their associativity).
1386 return assoc_class($op->first);
1388 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1391 # Left associative operators, like `+', for which
1392 # $a + $b + $c is equivalent to ($a + $b) + $c
1395 %left = ('multiply' => 19, 'i_multiply' => 19,
1396 'divide' => 19, 'i_divide' => 19,
1397 'modulo' => 19, 'i_modulo' => 19,
1399 'add' => 18, 'i_add' => 18,
1400 'subtract' => 18, 'i_subtract' => 18,
1402 'left_shift' => 17, 'right_shift' => 17,
1404 'bit_or' => 12, 'bit_xor' => 12,
1406 'or' => 2, 'xor' => 2,
1410 sub deparse_binop_left {
1412 my($op, $left, $prec) = @_;
1413 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1414 and $left{assoc_class($op)} == $left{assoc_class($left)})
1416 return $self->deparse($left, $prec - .00001);
1418 return $self->deparse($left, $prec);
1422 # Right associative operators, like `=', for which
1423 # $a = $b = $c is equivalent to $a = ($b = $c)
1426 %right = ('pow' => 22,
1427 'sassign=' => 7, 'aassign=' => 7,
1428 'multiply=' => 7, 'i_multiply=' => 7,
1429 'divide=' => 7, 'i_divide=' => 7,
1430 'modulo=' => 7, 'i_modulo=' => 7,
1432 'add=' => 7, 'i_add=' => 7,
1433 'subtract=' => 7, 'i_subtract=' => 7,
1435 'left_shift=' => 7, 'right_shift=' => 7,
1437 'bit_or=' => 7, 'bit_xor=' => 7,
1443 sub deparse_binop_right {
1445 my($op, $right, $prec) = @_;
1446 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1447 and $right{assoc_class($op)} == $right{assoc_class($right)})
1449 return $self->deparse($right, $prec - .00001);
1451 return $self->deparse($right, $prec);
1457 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1458 my $left = $op->first;
1459 my $right = $op->last;
1461 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1465 if ($flags & SWAP_CHILDREN) {
1466 ($left, $right) = ($right, $left);
1468 $left = $self->deparse_binop_left($op, $left, $prec);
1469 $right = $self->deparse_binop_right($op, $right, $prec);
1470 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1473 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1474 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1475 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1476 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1477 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1478 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1479 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1480 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1481 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1482 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1483 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1485 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1486 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1487 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1488 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1489 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1491 sub pp_eq { binop(@_, "==", 14) }
1492 sub pp_ne { binop(@_, "!=", 14) }
1493 sub pp_lt { binop(@_, "<", 15) }
1494 sub pp_gt { binop(@_, ">", 15) }
1495 sub pp_ge { binop(@_, ">=", 15) }
1496 sub pp_le { binop(@_, "<=", 15) }
1497 sub pp_ncmp { binop(@_, "<=>", 14) }
1498 sub pp_i_eq { binop(@_, "==", 14) }
1499 sub pp_i_ne { binop(@_, "!=", 14) }
1500 sub pp_i_lt { binop(@_, "<", 15) }
1501 sub pp_i_gt { binop(@_, ">", 15) }
1502 sub pp_i_ge { binop(@_, ">=", 15) }
1503 sub pp_i_le { binop(@_, "<=", 15) }
1504 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1506 sub pp_seq { binop(@_, "eq", 14) }
1507 sub pp_sne { binop(@_, "ne", 14) }
1508 sub pp_slt { binop(@_, "lt", 15) }
1509 sub pp_sgt { binop(@_, "gt", 15) }
1510 sub pp_sge { binop(@_, "ge", 15) }
1511 sub pp_sle { binop(@_, "le", 15) }
1512 sub pp_scmp { binop(@_, "cmp", 14) }
1514 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1515 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1517 # `.' is special because concats-of-concats are optimized to save copying
1518 # by making all but the first concat stacked. The effect is as if the
1519 # programmer had written `($a . $b) .= $c', except legal.
1520 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1524 my $left = $op->first;
1525 my $right = $op->last;
1528 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1532 $left = $self->deparse_binop_left($op, $left, $prec);
1533 $right = $self->deparse_binop_right($op, $right, $prec);
1534 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1537 # `x' is weird when the left arg is a list
1541 my $left = $op->first;
1542 my $right = $op->last;
1545 if ($op->flags & OPf_STACKED) {
1549 if (null($right)) { # list repeat; count is inside left-side ex-list
1550 my $kid = $left->first->sibling; # skip pushmark
1552 for (; !null($kid->sibling); $kid = $kid->sibling) {
1553 push @exprs, $self->deparse($kid, 6);
1556 $left = "(" . join(", ", @exprs). ")";
1558 $left = $self->deparse_binop_left($op, $left, $prec);
1560 $right = $self->deparse_binop_right($op, $right, $prec);
1561 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1566 my ($op, $cx, $type) = @_;
1567 my $left = $op->first;
1568 my $right = $left->sibling;
1569 $left = $self->deparse($left, 9);
1570 $right = $self->deparse($right, 9);
1571 return $self->maybe_parens("$left $type $right", $cx, 9);
1577 my $flip = $op->first;
1578 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1579 return $self->range($flip->first, $cx, $type);
1582 # one-line while/until is handled in pp_leave
1586 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1587 my $left = $op->first;
1588 my $right = $op->first->sibling;
1589 if ($cx == 0 and is_scope($right) and $blockname
1590 and $self->{'expand'} < 7)
1592 $left = $self->deparse($left, 1);
1593 $right = $self->deparse($right, 0);
1594 return "$blockname ($left) {\n\t$right\n\b}\cK";
1595 } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1596 and $self->{'expand'} < 7) { # $b if $a
1597 $right = $self->deparse($right, 1);
1598 $left = $self->deparse($left, 1);
1599 return "$right $blockname $left";
1600 } elsif ($cx > $lowprec and $highop) { # $a && $b
1601 $left = $self->deparse_binop_left($op, $left, $highprec);
1602 $right = $self->deparse_binop_right($op, $right, $highprec);
1603 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1604 } else { # $a and $b
1605 $left = $self->deparse_binop_left($op, $left, $lowprec);
1606 $right = $self->deparse_binop_right($op, $right, $lowprec);
1607 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1611 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1612 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1614 # xor is syntactically a logop, but it's really a binop (contrary to
1615 # old versions of opcode.pl). Syntax is what matters here.
1616 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1620 my ($op, $cx, $opname) = @_;
1621 my $left = $op->first;
1622 my $right = $op->first->sibling->first; # skip sassign
1623 $left = $self->deparse($left, 7);
1624 $right = $self->deparse($right, 7);
1625 return $self->maybe_parens("$left $opname $right", $cx, 7);
1628 sub pp_andassign { logassignop(@_, "&&=") }
1629 sub pp_orassign { logassignop(@_, "||=") }
1633 my($op, $cx, $name) = @_;
1635 my $parens = ($cx >= 5) || $self->{'parens'};
1636 my $kid = $op->first->sibling;
1637 return $name if null $kid;
1638 my $first = $self->deparse($kid, 6);
1639 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1640 push @exprs, $first;
1641 $kid = $kid->sibling;
1642 for (; !null($kid); $kid = $kid->sibling) {
1643 push @exprs, $self->deparse($kid, 6);
1646 return "$name(" . join(", ", @exprs) . ")";
1648 return "$name " . join(", ", @exprs);
1652 sub pp_bless { listop(@_, "bless") }
1653 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1654 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1655 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1656 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1657 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1658 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1659 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1660 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1661 sub pp_unpack { listop(@_, "unpack") }
1662 sub pp_pack { listop(@_, "pack") }
1663 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1664 sub pp_splice { listop(@_, "splice") }
1665 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1666 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1667 sub pp_reverse { listop(@_, "reverse") }
1668 sub pp_warn { listop(@_, "warn") }
1669 sub pp_die { listop(@_, "die") }
1670 # Actually, return is exempt from the LLAFR (see examples in this very
1671 # module!), but for consistency's sake, ignore that fact
1672 sub pp_return { listop(@_, "return") }
1673 sub pp_open { listop(@_, "open") }
1674 sub pp_pipe_op { listop(@_, "pipe") }
1675 sub pp_tie { listop(@_, "tie") }
1676 sub pp_binmode { listop(@_, "binmode") }
1677 sub pp_dbmopen { listop(@_, "dbmopen") }
1678 sub pp_sselect { listop(@_, "select") }
1679 sub pp_select { listop(@_, "select") }
1680 sub pp_read { listop(@_, "read") }
1681 sub pp_sysopen { listop(@_, "sysopen") }
1682 sub pp_sysseek { listop(@_, "sysseek") }
1683 sub pp_sysread { listop(@_, "sysread") }
1684 sub pp_syswrite { listop(@_, "syswrite") }
1685 sub pp_send { listop(@_, "send") }
1686 sub pp_recv { listop(@_, "recv") }
1687 sub pp_seek { listop(@_, "seek") }
1688 sub pp_fcntl { listop(@_, "fcntl") }
1689 sub pp_ioctl { listop(@_, "ioctl") }
1690 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1691 sub pp_socket { listop(@_, "socket") }
1692 sub pp_sockpair { listop(@_, "sockpair") }
1693 sub pp_bind { listop(@_, "bind") }
1694 sub pp_connect { listop(@_, "connect") }
1695 sub pp_listen { listop(@_, "listen") }
1696 sub pp_accept { listop(@_, "accept") }
1697 sub pp_shutdown { listop(@_, "shutdown") }
1698 sub pp_gsockopt { listop(@_, "getsockopt") }
1699 sub pp_ssockopt { listop(@_, "setsockopt") }
1700 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1701 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1702 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1703 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1704 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1705 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1706 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1707 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1708 sub pp_open_dir { listop(@_, "opendir") }
1709 sub pp_seekdir { listop(@_, "seekdir") }
1710 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1711 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1712 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1713 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1714 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1715 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1716 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1717 sub pp_shmget { listop(@_, "shmget") }
1718 sub pp_shmctl { listop(@_, "shmctl") }
1719 sub pp_shmread { listop(@_, "shmread") }
1720 sub pp_shmwrite { listop(@_, "shmwrite") }
1721 sub pp_msgget { listop(@_, "msgget") }
1722 sub pp_msgctl { listop(@_, "msgctl") }
1723 sub pp_msgsnd { listop(@_, "msgsnd") }
1724 sub pp_msgrcv { listop(@_, "msgrcv") }
1725 sub pp_semget { listop(@_, "semget") }
1726 sub pp_semctl { listop(@_, "semctl") }
1727 sub pp_semop { listop(@_, "semop") }
1728 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1729 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1730 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1731 sub pp_gsbyname { listop(@_, "getservbyname") }
1732 sub pp_gsbyport { listop(@_, "getservbyport") }
1733 sub pp_syscall { listop(@_, "syscall") }
1738 my $text = $self->dq($op->first->sibling); # skip pushmark
1739 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1740 or $text =~ /[<>]/) {
1741 return 'glob(' . single_delim('qq', '"', $text) . ')';
1743 return '<' . $text . '>';
1747 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1748 # be a filehandle. This could probably be better fixed in the core
1749 # by moving the GV lookup into ck_truc.
1755 my $parens = ($cx >= 5) || $self->{'parens'};
1756 my $kid = $op->first->sibling;
1758 if ($op->flags & OPf_SPECIAL) {
1759 # $kid is an OP_CONST
1760 $fh = $self->const_sv($kid)->PV;
1762 $fh = $self->deparse($kid, 6);
1763 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1765 my $len = $self->deparse($kid->sibling, 6);
1767 return "truncate($fh, $len)";
1769 return "truncate $fh, $len";
1775 my($op, $cx, $name) = @_;
1777 my $kid = $op->first->sibling;
1779 if ($op->flags & OPf_STACKED) {
1781 $indir = $indir->first; # skip rv2gv
1782 if (is_scope($indir)) {
1783 $indir = "{" . $self->deparse($indir, 0) . "}";
1785 $indir = $self->deparse($indir, 24);
1787 $indir = $indir . " ";
1788 $kid = $kid->sibling;
1790 for (; !null($kid); $kid = $kid->sibling) {
1791 $expr = $self->deparse($kid, 6);
1794 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
1798 sub pp_prtf { indirop(@_, "printf") }
1799 sub pp_print { indirop(@_, "print") }
1800 sub pp_sort { indirop(@_, "sort") }
1804 my($op, $cx, $name) = @_;
1806 my $kid = $op->first; # this is the (map|grep)start
1807 $kid = $kid->first->sibling; # skip a pushmark
1808 my $code = $kid->first; # skip a null
1809 if (is_scope $code) {
1810 $code = "{" . $self->deparse($code, 0) . "} ";
1812 $code = $self->deparse($code, 24) . ", ";
1814 $kid = $kid->sibling;
1815 for (; !null($kid); $kid = $kid->sibling) {
1816 $expr = $self->deparse($kid, 6);
1817 push @exprs, $expr if $expr;
1819 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1822 sub pp_mapwhile { mapop(@_, "map") }
1823 sub pp_grepwhile { mapop(@_, "grep") }
1829 my $kid = $op->first->sibling; # skip pushmark
1831 my $local = "either"; # could be local(...) or my(...)
1832 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1833 # This assumes that no other private flags equal 128, and that
1834 # OPs that store things other than flags in their op_private,
1835 # like OP_AELEMFAST, won't be immediate children of a list.
1836 unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
1838 $local = ""; # or not
1841 if ($lop->name =~ /^pad[ash]v$/) { # my()
1842 ($local = "", last) if $local eq "local";
1844 } elsif ($lop->name ne "undef") { # local()
1845 ($local = "", last) if $local eq "my";
1849 $local = "" if $local eq "either"; # no point if it's all undefs
1850 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1851 for (; !null($kid); $kid = $kid->sibling) {
1853 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
1858 $self->{'avoid_local'}{$$lop}++;
1859 $expr = $self->deparse($kid, 6);
1860 delete $self->{'avoid_local'}{$$lop};
1862 $expr = $self->deparse($kid, 6);
1867 return "$local(" . join(", ", @exprs) . ")";
1869 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1873 sub is_ifelse_cont {
1875 return ($op->name eq "null" and class($op) eq "UNOP"
1876 and $op->first->name =~ /^(and|cond_expr)$/
1877 and is_scope($op->first->first->sibling));
1883 my $cond = $op->first;
1884 my $true = $cond->sibling;
1885 my $false = $true->sibling;
1886 my $cuddle = $self->{'cuddle'};
1887 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
1888 (is_scope($false) || is_ifelse_cont($false))
1889 and $self->{'expand'} < 7) {
1890 $cond = $self->deparse($cond, 8);
1891 $true = $self->deparse($true, 8);
1892 $false = $self->deparse($false, 8);
1893 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1896 $cond = $self->deparse($cond, 1);
1897 $true = $self->deparse($true, 0);
1898 my $head = "if ($cond) {\n\t$true\n\b}";
1900 while (!null($false) and is_ifelse_cont($false)) {
1901 my $newop = $false->first;
1902 my $newcond = $newop->first;
1903 my $newtrue = $newcond->sibling;
1904 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1905 $newcond = $self->deparse($newcond, 1);
1906 $newtrue = $self->deparse($newtrue, 0);
1907 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1909 if (!null($false)) {
1910 $false = $cuddle . "else {\n\t" .
1911 $self->deparse($false, 0) . "\n\b}\cK";
1915 return $head . join($cuddle, "", @elsifs) . $false;
1920 my($op, $cx, $init) = @_;
1921 my $enter = $op->first;
1922 my $kid = $enter->sibling;
1923 local(@$self{qw'curstash warnings hints'})
1924 = @$self{qw'curstash warnings hints'};
1929 if ($kid->name eq "lineseq") { # bare or infinite loop
1930 if (is_state $kid->last) { # infinite
1931 $head = "for (;;) "; # shorter than while (1)
1937 } elsif ($enter->name eq "enteriter") { # foreach
1938 my $ary = $enter->first->sibling; # first was pushmark
1939 my $var = $ary->sibling;
1940 if ($enter->flags & OPf_STACKED
1941 and not null $ary->first->sibling->sibling)
1943 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1944 $self->deparse($ary->first->sibling->sibling, 9);
1946 $ary = $self->deparse($ary, 1);
1949 if ($enter->flags & OPf_SPECIAL) { # thread special var
1950 $var = $self->pp_threadsv($enter, 1);
1951 } else { # regular my() variable
1952 $var = $self->pp_padsv($enter, 1);
1953 if ($self->padname_sv($enter->targ)->IVX ==
1954 $kid->first->first->sibling->last->cop_seq)
1956 # If the scope of this variable closes at the last
1957 # statement of the loop, it must have been
1959 $var = "my " . $var;
1962 } elsif ($var->name eq "rv2gv") {
1963 $var = $self->pp_rv2sv($var, 1);
1964 } elsif ($var->name eq "gv") {
1965 $var = "\$" . $self->deparse($var, 1);
1967 $head = "foreach $var ($ary) ";
1968 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1969 } elsif ($kid->name eq "null") { # while/until
1971 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
1972 $cond = $self->deparse($kid->first, 1);
1973 $head = "$name ($cond) ";
1974 $body = $kid->first->sibling;
1975 } elsif ($kid->name eq "stub") { # bare and empty
1976 return "{;}"; # {} could be a hashref
1978 # If there isn't a continue block, then the next pointer for the loop
1979 # will point to the unstack, which is kid's penultimate child, except
1980 # in a bare loop, when it will point to the leaveloop. When neither of
1981 # these conditions hold, then the third-to-last child in the continue
1982 # block (or the last in a bare loop).
1983 my $cont_start = $enter->nextop;
1985 if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
1987 $cont = $body->last;
1989 $cont = $body->first;
1990 while (!null($cont->sibling->sibling->sibling)) {
1991 $cont = $cont->sibling;
1994 my $state = $body->first;
1995 my $cuddle = $self->{'cuddle'};
1997 for (; $$state != $$cont; $state = $state->sibling) {
1998 push @states, $state;
2000 $body = $self->lineseq(@states);
2001 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2002 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2005 $cont = $cuddle . "continue {\n\t" .
2006 $self->deparse($cont, 0) . "\n\b}\cK";
2009 return "" if !defined $body;
2011 $body = $self->deparse($body, 0);
2013 return $head . "{\n\t" . $body . "\n\b}" . $cont;
2016 sub pp_leaveloop { loop_common(@_, "") }
2021 my $init = $self->deparse($op, 1);
2022 return $self->loop_common($op->sibling, $cx, $init);
2027 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2030 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2031 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2036 if (class($op) eq "OP") {
2038 return $self->{'ex_const'} if $op->targ == OP_CONST;
2039 } elsif ($op->first->name eq "pushmark") {
2040 return $self->pp_list($op, $cx);
2041 } elsif ($op->first->name eq "enter") {
2042 return $self->pp_leave($op, $cx);
2043 } elsif ($op->targ == OP_STRINGIFY) {
2044 return $self->dquote($op, $cx);
2045 } elsif (!null($op->first->sibling) and
2046 $op->first->sibling->name eq "readline" and
2047 $op->first->sibling->flags & OPf_STACKED) {
2048 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2049 . $self->deparse($op->first->sibling, 7),
2051 } elsif (!null($op->first->sibling) and
2052 $op->first->sibling->name eq "trans" and
2053 $op->first->sibling->flags & OPf_STACKED) {
2054 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2055 . $self->deparse($op->first->sibling, 20),
2058 return $self->deparse($op->first, $cx);
2065 return $self->padname_sv($targ)->PVX;
2071 return substr($self->padname($op->targ), 1); # skip $/@/%
2077 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2080 sub pp_padav { pp_padsv(@_) }
2081 sub pp_padhv { pp_padsv(@_) }
2086 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2087 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2088 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2095 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2101 if (class($op) eq "PADOP") {
2102 return $self->padval($op->padix);
2103 } else { # class($op) eq "SVOP"
2111 my $gv = $self->gv_or_padgv($op);
2112 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
2118 my $gv = $self->gv_or_padgv($op);
2119 return $self->gv_name($gv);
2125 my $gv = $self->gv_or_padgv($op);
2126 return "\$" . $self->gv_name($gv) . "[" .
2127 ($op->private + $self->{'arybase'}) . "]";
2132 my($op, $cx, $type) = @_;
2133 my $kid = $op->first;
2134 my $str = $self->deparse($kid, 0);
2135 return $type . (is_scalar($kid) ? $str : "{$str}");
2138 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2139 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2140 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2146 if ($op->first->name eq "padav") {
2147 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2149 return $self->maybe_local($op, $cx,
2150 $self->rv2x($op->first, $cx, '$#'));
2154 # skip down to the old, ex-rv2cv
2155 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
2160 my $kid = $op->first;
2161 if ($kid->name eq "const") { # constant list
2162 my $av = $self->const_sv($kid);
2163 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2165 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2169 sub is_subscriptable {
2171 if ($op->name =~ /^[ahg]elem/) {
2173 } elsif ($op->name eq "entersub") {
2174 my $kid = $op->first;
2175 return 0 unless null $kid->sibling;
2177 $kid = $kid->sibling until null $kid->sibling;
2178 return 0 if is_scope($kid);
2180 return 0 if $kid->name eq "gv";
2181 return 0 if is_scalar($kid);
2182 return is_subscriptable($kid);
2190 my ($op, $cx, $left, $right, $padname) = @_;
2191 my($array, $idx) = ($op->first, $op->first->sibling);
2192 unless ($array->name eq $padname) { # Maybe this has been fixed
2193 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2195 if ($array->name eq $padname) {
2196 $array = $self->padany($array);
2197 } elsif (is_scope($array)) { # ${expr}[0]
2198 $array = "{" . $self->deparse($array, 0) . "}";
2199 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2200 $array = $self->deparse($array, 24);
2202 # $x[20][3]{hi} or expr->[20]
2203 my $arrow = is_subscriptable($array) ? "" : "->";
2204 return $self->deparse($array, 24) . $arrow .
2205 $left . $self->deparse($idx, 1) . $right;
2207 $idx = $self->deparse($idx, 1);
2209 # Outer parens in an array index will confuse perl
2210 # if we're interpolating in a regular expression, i.e.
2211 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2213 # If $self->{parens}, then an initial '(' will
2214 # definitely be paired with a final ')'. If
2215 # !$self->{parens}, the misleading parens won't
2216 # have been added in the first place.
2218 # [You might think that we could get "(...)...(...)"
2219 # where the initial and final parens do not match
2220 # each other. But we can't, because the above would
2221 # only happen if there's an infix binop between the
2222 # two pairs of parens, and *that* means that the whole
2223 # expression would be parenthesized as well.]
2225 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2227 return "\$" . $array . $left . $idx . $right;
2230 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2231 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2236 my($glob, $part) = ($op->first, $op->last);
2237 $glob = $glob->first; # skip rv2gv
2238 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2239 my $scope = is_scope($glob);
2240 $glob = $self->deparse($glob, 0);
2241 $part = $self->deparse($part, 1);
2242 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2247 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2249 my(@elems, $kid, $array, $list);
2250 if (class($op) eq "LISTOP") {
2252 } else { # ex-hslice inside delete()
2253 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2257 $array = $array->first
2258 if $array->name eq $regname or $array->name eq "null";
2259 if (is_scope($array)) {
2260 $array = "{" . $self->deparse($array, 0) . "}";
2261 } elsif ($array->name eq $padname) {
2262 $array = $self->padany($array);
2264 $array = $self->deparse($array, 24);
2266 $kid = $op->first->sibling; # skip pushmark
2267 if ($kid->name eq "list") {
2268 $kid = $kid->first->sibling; # skip list, pushmark
2269 for (; !null $kid; $kid = $kid->sibling) {
2270 push @elems, $self->deparse($kid, 6);
2272 $list = join(", ", @elems);
2274 $list = $self->deparse($kid, 1);
2276 return "\@" . $array . $left . $list . $right;
2279 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2280 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2285 my $idx = $op->first;
2286 my $list = $op->last;
2288 $list = $self->deparse($list, 1);
2289 $idx = $self->deparse($idx, 1);
2290 return "($list)" . "[$idx]";
2295 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2300 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2306 my $kid = $op->first->sibling; # skip pushmark
2307 my($meth, $obj, @exprs);
2308 if ($kid->name eq "list" and want_list $kid) {
2309 # When an indirect object isn't a bareword but the args are in
2310 # parens, the parens aren't part of the method syntax (the LLAFR
2311 # doesn't apply), but they make a list with OPf_PARENS set that
2312 # doesn't get flattened by the append_elem that adds the method,
2313 # making a (object, arg1, arg2, ...) list where the object
2314 # usually is. This can be distinguished from
2315 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2316 # object) because in the later the list is in scalar context
2317 # as the left side of -> always is, while in the former
2318 # the list is in list context as method arguments always are.
2319 # (Good thing there aren't method prototypes!)
2320 $meth = $kid->sibling;
2321 $kid = $kid->first->sibling; # skip pushmark
2323 $kid = $kid->sibling;
2324 for (; not null $kid; $kid = $kid->sibling) {
2325 push @exprs, $self->deparse($kid, 6);
2329 $kid = $kid->sibling;
2330 for (; not null $kid->sibling; $kid = $kid->sibling) {
2331 push @exprs, $self->deparse($kid, 6);
2335 $obj = $self->deparse($obj, 24);
2336 if ($meth->name eq "method_named") {
2337 $meth = $self->const_sv($meth)->PV;
2339 $meth = $meth->first;
2340 if ($meth->name eq "const") {
2341 # As of 5.005_58, this case is probably obsoleted by the
2342 # method_named case above
2343 $meth = $self->const_sv($meth)->PV; # needs to be bare
2345 $meth = $self->deparse($meth, 1);
2348 my $args = join(", ", @exprs);
2349 $kid = $obj . "->" . $meth;
2351 return $kid . "(" . $args . ")"; # parens mandatory
2357 # returns "&" if the prototype doesn't match the args,
2358 # or ("", $args_after_prototype_demunging) if it does.
2361 my($proto, @args) = @_;
2365 # An unbackslashed @ or % gobbles up the rest of the args
2366 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2368 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2371 return "&" if @args;
2372 } elsif ($chr eq ";") {
2374 } elsif ($chr eq "@" or $chr eq "%") {
2375 push @reals, map($self->deparse($_, 6), @args);
2381 if (want_scalar $arg) {
2382 push @reals, $self->deparse($arg, 6);
2386 } elsif ($chr eq "&") {
2387 if ($arg->name =~ /^(s?refgen|undef)$/) {
2388 push @reals, $self->deparse($arg, 6);
2392 } elsif ($chr eq "*") {
2393 if ($arg->name =~ /^s?refgen$/
2394 and $arg->first->first->name eq "rv2gv")
2396 $real = $arg->first->first; # skip refgen, null
2397 if ($real->first->name eq "gv") {
2398 push @reals, $self->deparse($real, 6);
2400 push @reals, $self->deparse($real->first, 6);
2405 } elsif (substr($chr, 0, 1) eq "\\") {
2406 $chr = substr($chr, 1);
2407 if ($arg->name =~ /^s?refgen$/ and
2408 !null($real = $arg->first) and
2409 ($chr eq "\$" && is_scalar($real->first)
2411 && $real->first->sibling->name
2414 && $real->first->sibling->name
2416 #or ($chr eq "&" # This doesn't work
2417 # && $real->first->name eq "rv2cv")
2419 && $real->first->name eq "rv2gv")))
2421 push @reals, $self->deparse($real, 6);
2428 return "&" if $proto and !$doneok; # too few args and no `;'
2429 return "&" if @args; # too many args
2430 return ("", join ", ", @reals);
2436 return $self->method($op, $cx) unless null $op->first->sibling;
2440 if ($op->flags & OPf_SPECIAL) {
2442 } elsif ($op->private & OPpENTERSUB_AMPER) {
2446 $kid = $kid->first->sibling; # skip ex-list, pushmark
2447 for (; not null $kid->sibling; $kid = $kid->sibling) {
2452 if (is_scope($kid)) {
2454 $kid = "{" . $self->deparse($kid, 0) . "}";
2455 } elsif ($kid->first->name eq "gv") {
2456 my $gv = $self->gv_or_padgv($kid->first);
2457 if (class($gv->CV) ne "SPECIAL") {
2458 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2460 $simple = 1; # only calls of named functions can be prototyped
2461 $kid = $self->deparse($kid, 24);
2462 } elsif (is_scalar $kid->first) {
2464 $kid = $self->deparse($kid, 24);
2467 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2468 $kid = $self->deparse($kid, 24) . $arrow;
2471 # Doesn't matter how many prototypes there are, if
2472 # they haven't happened yet!
2473 my $declared = exists $self->{'subs_declared'}{$kid};
2476 if ($declared and defined $proto and not $amper) {
2477 ($amper, $args) = $self->check_proto($proto, @exprs);
2478 if ($amper eq "&") {
2479 $args = join(", ", map($self->deparse($_, 6), @exprs));
2482 $args = join(", ", map($self->deparse($_, 6), @exprs));
2484 if ($prefix or $amper) {
2485 if ($op->flags & OPf_STACKED) {
2486 return $prefix . $amper . $kid . "(" . $args . ")";
2488 return $prefix . $amper. $kid;
2492 return "$kid(" . $args . ")";
2493 } elsif (defined $proto and $proto eq "") {
2495 } elsif (defined $proto and $proto eq "\$") {
2496 return $self->maybe_parens_func($kid, $args, $cx, 16);
2497 } elsif (defined($proto) && $proto or $simple) {
2498 return $self->maybe_parens_func($kid, $args, $cx, 5);
2500 return "$kid(" . $args . ")";
2505 sub pp_enterwrite { unop(@_, "write") }
2507 # escape things that cause interpolation in double quotes,
2508 # but not character escapes
2511 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2515 # the same, but treat $|, $), and $ at the end of the string differently
2518 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2519 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2523 # character escapes, but not delimiters that might need to be escaped
2524 sub escape_str { # ASCII, UTF8
2526 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
2528 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2534 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2535 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2539 # Don't do this for regexen
2542 $str =~ s/\\/\\\\/g;
2546 # Remove backslashes which precede literal control characters,
2547 # to avoid creating ambiguity when we escape the latter.
2551 # the insane complexity here is due to the behaviour of "\c\"
2552 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
2556 sub balanced_delim {
2558 my @str = split //, $str;
2559 my($ar, $open, $close, $fail, $c, $cnt);
2560 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2561 ($open, $close) = @$ar;
2562 $fail = 0; $cnt = 0;
2566 } elsif ($c eq $close) {
2575 $fail = 1 if $cnt != 0;
2576 return ($open, "$open$str$close") if not $fail;
2582 my($q, $default, $str) = @_;
2583 return "$default$str$default" if $default and index($str, $default) == -1;
2584 my($succeed, $delim);
2585 ($succeed, $str) = balanced_delim($str);
2586 return "$q$str" if $succeed;
2587 for $delim ('/', '"', '#') {
2588 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2591 $str =~ s/$default/\\$default/g;
2592 return "$default$str$default";
2601 if (class($sv) eq "SPECIAL") {
2602 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2603 } elsif (class($sv) eq "NULL") {
2605 } elsif ($sv->FLAGS & SVf_IOK) {
2606 return $sv->int_value;
2607 } elsif ($sv->FLAGS & SVf_NOK) {
2609 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
2610 return "\\(" . const($sv->RV) . ")"; # constant folded
2613 if ($str =~ /[^ -~]/) { # ASCII for non-printing
2614 return single_delim("qq", '"', uninterp escape_str unback $str);
2616 return single_delim("q", "'", unback $str);
2625 # the constant could be in the pad (under useithreads)
2626 $sv = $self->padval($op->targ) unless $$sv;
2633 if ($op->private & OPpCONST_ARYBASE) {
2636 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2637 # return $self->const_sv($op)->PV;
2639 my $sv = $self->const_sv($op);
2640 # return const($sv);
2642 return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
2648 my $type = $op->name;
2649 if ($type eq "const") {
2650 return '$[' if $op->private & OPpCONST_ARYBASE;
2651 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
2652 } elsif ($type eq "concat") {
2653 my $first = $self->dq($op->first);
2654 my $last = $self->dq($op->last);
2655 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2656 if ($last =~ /^[A-Z\\\^\[\]_?]/) {
2657 $first =~ s/([\$@])\^$/${1}{^}/; # "${^}W" etc
2659 elsif ($last =~ /^[{\[\w]/) {
2660 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2662 return $first . $last;
2663 } elsif ($type eq "uc") {
2664 return '\U' . $self->dq($op->first->sibling) . '\E';
2665 } elsif ($type eq "lc") {
2666 return '\L' . $self->dq($op->first->sibling) . '\E';
2667 } elsif ($type eq "ucfirst") {
2668 return '\u' . $self->dq($op->first->sibling);
2669 } elsif ($type eq "lcfirst") {
2670 return '\l' . $self->dq($op->first->sibling);
2671 } elsif ($type eq "quotemeta") {
2672 return '\Q' . $self->dq($op->first->sibling) . '\E';
2673 } elsif ($type eq "join") {
2674 return $self->deparse($op->last, 26); # was join($", @ary)
2676 return $self->deparse($op, 26);
2684 return single_delim("qx", '`', $self->dq($op->first->sibling));
2690 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2691 return $self->deparse($kid, $cx) if $self->{'unquote'};
2692 $self->maybe_targmy($kid, $cx,
2693 sub {single_delim("qq", '"', $self->dq($_[1]))});
2696 # OP_STRINGIFY is a listop, but it only ever has one arg
2697 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2699 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2700 # note that tr(from)/to/ is OK, but not tr/from/(to)
2702 my($from, $to) = @_;
2703 my($succeed, $delim);
2704 if ($from !~ m[/] and $to !~ m[/]) {
2705 return "/$from/$to/";
2706 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2707 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2710 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2711 return "$from$delim$to$delim" if index($to, $delim) == -1;
2714 return "$from/$to/";
2717 for $delim ('/', '"', '#') { # note no '
2718 return "$delim$from$delim$to$delim"
2719 if index($to . $from, $delim) == -1;
2721 $from =~ s[/][\\/]g;
2723 return "/$from/$to/";
2729 if ($n == ord '\\') {
2731 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2733 } elsif ($n == ord "\a") {
2735 } elsif ($n == ord "\b") {
2737 } elsif ($n == ord "\t") {
2739 } elsif ($n == ord "\n") {
2741 } elsif ($n == ord "\e") {
2743 } elsif ($n == ord "\f") {
2745 } elsif ($n == ord "\r") {
2747 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2748 return '\\c' . chr(ord("@") + $n);
2750 # return '\x' . sprintf("%02x", $n);
2751 return '\\' . sprintf("%03o", $n);
2757 my($str, $c, $tr) = ("");
2758 for ($c = 0; $c < @chars; $c++) {
2761 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2762 $chars[$c + 2] == $tr + 2)
2764 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2767 $str .= pchr($chars[$c]);
2773 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2776 sub tr_decode_byte {
2777 my($table, $flags) = @_;
2778 my(@table) = unpack("s256", $table);
2779 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2780 if ($table[ord "-"] != -1 and
2781 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2783 $tr = $table[ord "-"];
2784 $table[ord "-"] = -1;
2788 } else { # -2 ==> delete
2792 for ($c = 0; $c < 256; $c++) {
2795 push @from, $c; push @to, $tr;
2796 } elsif ($tr == -2) {
2800 @from = (@from, @delfrom);
2801 if ($flags & OPpTRANS_COMPLEMENT) {
2804 @from{@from} = (1) x @from;
2805 for ($c = 0; $c < 256; $c++) {
2806 push @newfrom, $c unless $from{$c};
2810 unless ($flags & OPpTRANS_DELETE || !@to) {
2811 pop @to while $#to and $to[$#to] == $to[$#to -1];
2814 $from = collapse(@from);
2815 $to = collapse(@to);
2816 $from .= "-" if $delhyphen;
2817 return ($from, $to);
2822 if ($x == ord "-") {
2829 # XXX This doesn't yet handle all cases correctly either
2831 sub tr_decode_utf8 {
2832 my($swash_hv, $flags) = @_;
2833 my %swash = $swash_hv->ARRAY;
2835 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2836 my $none = $swash{"NONE"}->IV;
2837 my $extra = $none + 1;
2838 my(@from, @delfrom, @to);
2840 foreach $line (split /\n/, $swash{'LIST'}->PV) {
2841 my($min, $max, $result) = split(/\t/, $line);
2848 $result = hex $result;
2849 if ($result == $extra) {
2850 push @delfrom, [$min, $max];
2852 push @from, [$min, $max];
2853 push @to, [$result, $result + $max - $min];
2856 for my $i (0 .. $#from) {
2857 if ($from[$i][0] == ord '-') {
2858 unshift @from, splice(@from, $i, 1);
2859 unshift @to, splice(@to, $i, 1);
2861 } elsif ($from[$i][1] == ord '-') {
2864 unshift @from, ord '-';
2865 unshift @to, ord '-';
2869 for my $i (0 .. $#delfrom) {
2870 if ($delfrom[$i][0] == ord '-') {
2871 push @delfrom, splice(@delfrom, $i, 1);
2873 } elsif ($delfrom[$i][1] == ord '-') {
2875 push @delfrom, ord '-';
2879 if (defined $final and $to[$#to][1] != $final) {
2880 push @to, [$final, $final];
2882 push @from, @delfrom;
2883 if ($flags & OPpTRANS_COMPLEMENT) {
2886 for my $i (0 .. $#from) {
2887 push @newfrom, [$next, $from[$i][0] - 1];
2888 $next = $from[$i][1] + 1;
2891 for my $range (@newfrom) {
2892 if ($range->[0] <= $range->[1]) {
2897 my($from, $to, $diff);
2898 for my $chunk (@from) {
2899 $diff = $chunk->[1] - $chunk->[0];
2901 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2902 } elsif ($diff == 1) {
2903 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2905 $from .= tr_chr($chunk->[0]);
2908 for my $chunk (@to) {
2909 $diff = $chunk->[1] - $chunk->[0];
2911 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2912 } elsif ($diff == 1) {
2913 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2915 $to .= tr_chr($chunk->[0]);
2918 #$final = sprintf("%04x", $final) if defined $final;
2919 #$none = sprintf("%04x", $none) if defined $none;
2920 #$extra = sprintf("%04x", $extra) if defined $extra;
2921 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2922 #print STDERR $swash{'LIST'}->PV;
2923 return (escape_str($from), escape_str($to));
2930 if (class($op) eq "PVOP") {
2931 ($from, $to) = tr_decode_byte($op->pv, $op->private);
2932 } else { # class($op) eq "SVOP"
2933 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2936 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2937 $flags .= "d" if $op->private & OPpTRANS_DELETE;
2938 $to = "" if $from eq $to and $flags eq "";
2939 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2940 return "tr" . double_delim($from, $to) . $flags;
2943 # Like dq(), but different
2947 my $type = $op->name;
2948 if ($type eq "const") {
2949 return '$[' if $op->private & OPpCONST_ARYBASE;
2950 return re_uninterp(escape_str(re_unback($self->const_sv($op)->as_string)));
2951 } elsif ($type eq "concat") {
2952 my $first = $self->re_dq($op->first);
2953 my $last = $self->re_dq($op->last);
2954 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2955 if ($last =~ /^[A-Z\\\^\[\]_?]/) {
2956 $first =~ s/([\$@])\^$/${1}{^}/;
2958 elsif ($last =~ /^[{\[\w]/) {
2959 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2961 return $first . $last;
2962 } elsif ($type eq "uc") {
2963 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2964 } elsif ($type eq "lc") {
2965 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2966 } elsif ($type eq "ucfirst") {
2967 return '\u' . $self->re_dq($op->first->sibling);
2968 } elsif ($type eq "lcfirst") {
2969 return '\l' . $self->re_dq($op->first->sibling);
2970 } elsif ($type eq "quotemeta") {
2971 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2972 } elsif ($type eq "join") {
2973 return $self->deparse($op->last, 26); # was join($", @ary)
2975 return $self->deparse($op, 26);
2982 my $kid = $op->first;
2983 $kid = $kid->first if $kid->name eq "regcmaybe";
2984 $kid = $kid->first if $kid->name eq "regcreset";
2985 return $self->re_dq($kid);
2988 # osmic acid -- see osmium tetroxide
2991 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2992 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2993 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2997 my($op, $cx, $name, $delim) = @_;
2998 my $kid = $op->first;
2999 my ($binop, $var, $re) = ("", "", "");
3000 if ($op->flags & OPf_STACKED) {
3002 $var = $self->deparse($kid, 20);
3003 $kid = $kid->sibling;
3006 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3008 $re = $self->deparse($kid, 1);
3011 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3012 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3013 $flags .= "i" if $op->pmflags & PMf_FOLD;
3014 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3015 $flags .= "o" if $op->pmflags & PMf_KEEP;
3016 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3017 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3018 $flags = $matchwords{$flags} if $matchwords{$flags};
3019 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3023 $re = single_delim($name, $delim, $re);
3027 return $self->maybe_parens("$var =~ $re", $cx, 20);
3033 sub pp_match { matchop(@_, "m", "/") }
3034 sub pp_pushre { matchop(@_, "m", "/") }
3035 sub pp_qr { matchop(@_, "qr", "") }
3040 my($kid, @exprs, $ary, $expr);
3042 if ($ {$kid->pmreplroot}) {
3043 $ary = '@' . $self->gv_name($kid->pmreplroot);
3045 for (; !null($kid); $kid = $kid->sibling) {
3046 push @exprs, $self->deparse($kid, 6);
3049 # handle special case of split(), and split(" ") that compiles to /\s+/
3051 if ($kid->flags & OPf_SPECIAL
3052 && $exprs[0] eq '/\\s+/'
3053 && $kid->pmflags & PMf_SKIPWHITE ) {
3057 $expr = "split(" . join(", ", @exprs) . ")";
3059 return $self->maybe_parens("$ary = $expr", $cx, 7);
3065 # oxime -- any of various compounds obtained chiefly by the action of
3066 # hydroxylamine on aldehydes and ketones and characterized by the
3067 # bivalent grouping C=NOH [Webster's Tenth]
3070 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3071 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3072 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3073 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3078 my $kid = $op->first;
3079 my($binop, $var, $re, $repl) = ("", "", "", "");
3080 if ($op->flags & OPf_STACKED) {
3082 $var = $self->deparse($kid, 20);
3083 $kid = $kid->sibling;
3086 if (null($op->pmreplroot)) {
3087 $repl = $self->dq($kid);
3088 $kid = $kid->sibling;
3090 $repl = $op->pmreplroot->first; # skip substcont
3091 while ($repl->name eq "entereval") {
3092 $repl = $repl->first;
3095 if ($op->pmflags & PMf_EVAL) {
3096 $repl = $self->deparse($repl, 0);
3098 $repl = $self->dq($repl);
3102 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3104 $re = $self->deparse($kid, 1);
3106 $flags .= "e" if $op->pmflags & PMf_EVAL;
3107 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3108 $flags .= "i" if $op->pmflags & PMf_FOLD;
3109 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3110 $flags .= "o" if $op->pmflags & PMf_KEEP;
3111 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3112 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3113 $flags = $substwords{$flags} if $substwords{$flags};
3115 return $self->maybe_parens("$var =~ s"
3116 . double_delim($re, $repl) . $flags,
3119 return "s". double_delim($re, $repl) . $flags;
3128 B::Deparse - Perl compiler backend to produce perl code
3132 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3133 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3137 B::Deparse is a backend module for the Perl compiler that generates
3138 perl source code, based on the internal compiled structure that perl
3139 itself creates after parsing a program. The output of B::Deparse won't
3140 be exactly the same as the original source, since perl doesn't keep
3141 track of comments or whitespace, and there isn't a one-to-one
3142 correspondence between perl's syntactical constructions and their
3143 compiled form, but it will often be close. When you use the B<-p>
3144 option, the output also includes parentheses even when they are not
3145 required by precedence, which can make it easy to see if perl is
3146 parsing your expressions the way you intended.
3148 Please note that this module is mainly new and untested code and is
3149 still under development, so it may change in the future.
3153 As with all compiler backend options, these must follow directly after
3154 the '-MO=Deparse', separated by a comma but not any white space.
3160 Add '#line' declarations to the output based on the line and file
3161 locations of the original code.
3165 Print extra parentheses. Without this option, B::Deparse includes
3166 parentheses in its output only when they are needed, based on the
3167 structure of your program. With B<-p>, it uses parentheses (almost)
3168 whenever they would be legal. This can be useful if you are used to
3169 LISP, or if you want to see how perl parses your input. If you say
3171 if ($var & 0x7f == 65) {print "Gimme an A!"}
3172 print ($which ? $a : $b), "\n";
3173 $name = $ENV{USER} or "Bob";
3175 C<B::Deparse,-p> will print
3178 print('Gimme an A!')
3180 (print(($which ? $a : $b)), '???');
3181 (($name = $ENV{'USER'}) or '???')
3183 which probably isn't what you intended (the C<'???'> is a sign that
3184 perl optimized away a constant value).
3188 Expand double-quoted strings into the corresponding combinations of
3189 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3192 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3196 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3197 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3199 Note that the expanded form represents the way perl handles such
3200 constructions internally -- this option actually turns off the reverse
3201 translation that B::Deparse usually does. On the other hand, note that
3202 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3203 of $y into a string before doing the assignment.
3205 =item B<-u>I<PACKAGE>
3207 Normally, B::Deparse deparses the main code of a program, all the subs
3208 called by the main program (and all the subs called by them,
3209 recursively), and any other subs in the main:: package. To include
3210 subs in other packages that aren't called directly, such as AUTOLOAD,
3211 DESTROY, other subs called automatically by perl, and methods (which
3212 aren't resolved to subs until runtime), use the B<-u> option. The
3213 argument to B<-u> is the name of a package, and should follow directly
3214 after the 'u'. Multiple B<-u> options may be given, separated by
3215 commas. Note that unlike some other backends, B::Deparse doesn't
3216 (yet) try to guess automatically when B<-u> is needed -- you must
3219 =item B<-s>I<LETTERS>
3221 Tweak the style of B::Deparse's output. The letters should follow
3222 directly after the 's', with no space or punctuation. The following
3223 options are available:
3229 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3246 The default is not to cuddle.
3250 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3254 Use tabs for each 8 columns of indent. The default is to use only spaces.
3255 For instance, if the style options are B<-si4T>, a line that's indented
3256 3 times will be preceded by one tab and four spaces; if the options were
3257 B<-si8T>, the same line would be preceded by three tabs.
3259 =item B<v>I<STRING>B<.>
3261 Print I<STRING> for the value of a constant that can't be determined
3262 because it was optimized away (mnemonic: this happens when a constant
3263 is used in B<v>oid context). The end of the string is marked by a period.
3264 The string should be a valid perl expression, generally a constant.
3265 Note that unless it's a number, it probably needs to be quoted, and on
3266 a command line quotes need to be protected from the shell. Some
3267 conventional values include 0, 1, 42, '', 'foo', and
3268 'Useless use of constant omitted' (which may need to be
3269 B<-sv"'Useless use of constant omitted'.">
3270 or something similar depending on your shell). The default is '???'.
3271 If you're using B::Deparse on a module or other file that's require'd,
3272 you shouldn't use a value that evaluates to false, since the customary
3273 true constant at the end of a module will be in void context when the
3274 file is compiled as a main program.
3280 Expand conventional syntax constructions into equivalent ones that expose
3281 their internal operation. I<LEVEL> should be a digit, with higher values
3282 meaning more expansion. As with B<-q>, this actually involves turning off
3283 special cases in B::Deparse's normal operations.
3285 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3286 while loops with continue blocks; for instance
3288 for ($i = 0; $i < 10; ++$i) {
3301 Note that in a few cases this translation can't be perfectly carried back
3302 into the source code -- if the loop's initializer declares a my variable,
3303 for instance, it won't have the correct scope outside of the loop.
3305 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3306 expressions using C<&&>, C<?:> and C<do {}>; for instance
3308 print 'hi' if $nice;
3320 $nice and print 'hi';
3321 $nice and do { print 'hi' };
3322 $nice ? do { print 'hi' } : do { print 'bye' };
3324 Long sequences of elsifs will turn into nested ternary operators, which
3325 B::Deparse doesn't know how to indent nicely.
3329 =head1 USING B::Deparse AS A MODULE
3334 $deparse = B::Deparse->new("-p", "-sC");
3335 $body = $deparse->coderef2text(\&func);
3336 eval "sub func $body"; # the inverse operation
3340 B::Deparse can also be used on a sub-by-sub basis from other perl
3345 $deparse = B::Deparse->new(OPTIONS)
3347 Create an object to store the state of a deparsing operation and any
3348 options. The options are the same as those that can be given on the
3349 command line (see L</OPTIONS>); options that are separated by commas
3350 after B<-MO=Deparse> should be given as separate strings. Some
3351 options, like B<-u>, don't make sense for a single subroutine, so
3354 =head2 ambient_pragmas
3356 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3358 The compilation of a subroutine can be affected by a few compiler
3359 directives, B<pragmas>. These are:
3373 Assigning to the special variable $[
3393 Ordinarily, if you use B::Deparse on a subroutine which has
3394 been compiled in the presence of one or more of these pragmas,
3395 the output will include statements to turn on the appropriate
3396 directives. So if you then compile the code returned by coderef2text,
3397 it will behave the same way as the subroutine which you deparsed.
3399 However, you may know that you intend to use the results in a
3400 particular context, where some pragmas are already in scope. In
3401 this case, you use the B<ambient_pragmas> method to describe the
3402 assumptions you wish to make.
3404 The parameters it accepts are:
3410 Takes a string, possibly containing several values separated
3411 by whitespace. The special values "all" and "none" mean what you'd
3414 $deparse->ambient_pragmas(strict => 'subs refs');
3418 Takes a number, the value of the array base $[.
3426 If the value is true, then the appropriate pragma is assumed to
3427 be in the ambient scope, otherwise not.
3431 Takes a string, possibly containing a whitespace-separated list of
3432 values. The values "all" and "none" are special. It's also permissible
3433 to pass an array reference here.
3435 $deparser->ambient_pragmas(re => 'eval');
3440 Takes a string, possibly containing a whitespace-separated list of
3441 values. The values "all" and "none" are special, again. It's also
3442 permissible to pass an array reference here.
3444 $deparser->ambient_pragmas(warnings => [qw[void io]]);
3446 If one of the values is the string "FATAL", then all the warnings
3447 in that list will be considered fatal, just as with the B<warnings>
3448 pragma itself. Should you need to specify that some warnings are
3449 fatal, and others are merely enabled, you can pass the B<warnings>
3452 $deparser->ambient_pragmas(
3454 warnings => [FATAL => qw/void io/],
3457 See L<perllexwarn> for more information about lexical warnings.
3463 These two parameters are used to specify the ambient pragmas in
3464 the format used by the special variables $^H and ${^WARNING_BITS}.
3466 They exist principally so that you can write code like:
3468 { my ($hint_bits, $warning_bits);
3469 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3470 $deparser->ambient_pragmas (
3471 hint_bits => $hint_bits,
3472 warning_bits => $warning_bits,
3476 which specifies that the ambient pragmas are exactly those which
3477 are in scope at the point of calling.
3483 $body = $deparse->coderef2text(\&func)
3484 $body = $deparse->coderef2text(sub ($$) { ... })
3486 Return source code for the body of a subroutine (a block, optionally
3487 preceded by a prototype in parens), given a reference to the
3488 sub. Because a subroutine can have no names, or more than one name,
3489 this method doesn't return a complete subroutine definition -- if you
3490 want to eval the result, you should prepend "sub subname ", or "sub "
3491 for an anonymous function constructor. Unless the sub was defined in
3492 the main:: package, the code will include a package declaration.
3496 See the 'to do' list at the beginning of the module file.
3500 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3501 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3502 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3503 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.