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?)
115 # Tests that will always fail:
116 # comp/redef.t -- all (redefinition happens at compile time)
118 # Object fields (were globals):
121 # (local($a), local($b)) and local($a, $b) have the same internal
122 # representation but the short form looks better. We notice we can
123 # use a large-scale local when checking the list, but need to prevent
124 # individual locals too. This hash holds the addresses of OPs that
125 # have already had their local-ness accounted for. The same thing
129 # CV for current sub (or main program) being deparsed
132 # COP for statement being deparsed
135 # name of the current package for deparsed code
138 # array of [cop_seq, CV, 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($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, $cv, $is_form];
231 my $ent = shift @{$self->{'subs_todo'}};
234 my $name = $self->gv_name($gv);
236 return "format $name =\n"
237 . $self->deparse_format($ent->[1]->FORM). "\n";
239 $self->{'subs_declared'}{$name} = 1;
240 if ($name eq "BEGIN") {
241 my $use_dec = $self->begin_is_use($cv);
242 return $use_dec if defined ($use_dec);
244 return "sub $name " . $self->deparse_sub($cv);
248 # Return a "use" declaration for this BEGIN block, if appropriate
250 my ($self, $cv) = @_;
251 my $root = $cv->ROOT;
253 #B::walkoptree($cv->ROOT, "debug");
254 my $lineseq = $root->first;
255 return if $lineseq->name ne "lineseq";
257 my $req_op = $lineseq->first->sibling;
258 return if $req_op->name ne "require";
261 if ($req_op->first->private & OPpCONST_BARE) {
262 # Actually it should always be a bareword
263 $module = $self->const_sv($req_op->first)->PV;
264 $module =~ s[/][::]g;
268 $module = const($self->const_sv($req_op->first));
272 my $version_op = $req_op->sibling;
273 return if class($version_op) eq "NULL";
274 if ($version_op->name eq "lineseq") {
275 # We have a version parameter; skip nextstate & pushmark
276 my $constop = $version_op->first->next->next;
278 return unless $self->const_sv($constop)->PV eq $module;
279 $constop = $constop->sibling;
281 $version = $self->const_sv($constop)->int_value;
282 $constop = $constop->sibling;
283 return if $constop->name ne "method_named";
284 return if $self->const_sv($constop)->PV ne "VERSION";
287 $lineseq = $version_op->sibling;
288 return if $lineseq->name ne "lineseq";
289 my $entersub = $lineseq->first->sibling;
290 if ($entersub->name eq "stub") {
291 return "use $module $version ();\n" if defined $version;
292 return "use $module ();\n";
294 return if $entersub->name ne "entersub";
296 # See if there are import arguments
299 my $constop = $entersub->first->sibling; # Skip over pushmark
300 return unless $self->const_sv($constop)->PV eq $module;
302 # Pull out the arguments
303 for ($constop=$constop->sibling; $constop->name eq "const";
304 $constop = $constop->sibling) {
305 $args .= ", " if length($args);
306 $args .= $self->deparse($constop, 6);
310 my $method_named = $constop;
311 return if $method_named->name ne "method_named";
312 my $method_name = $self->const_sv($method_named)->PV;
314 if ($method_name eq "unimport") {
318 # Certain pragmas are dealt with using hint bits,
319 # so we ignore them here
320 if ($module eq 'strict' || $module eq 'integer'
321 || $module eq 'bytes') {
325 if (defined $version && length $args) {
326 return "$use $module $version ($args);\n";
327 } elsif (defined $version) {
328 return "$use $module $version;\n";
329 } elsif (length $args) {
330 return "$use $module ($args);\n";
332 return "$use $module;\n";
339 if ($op->flags & OPf_KIDS) {
341 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
342 walk_tree($kid, $sub);
351 $op = shift if null $op;
352 return if !$op or null $op;
355 if ($op->name eq "gv") {
356 my $gv = $self->gv_or_padgv($op);
357 if ($op->next->name eq "entersub") {
358 return if $self->{'subs_done'}{$$gv}++;
359 return if class($gv->CV) eq "SPECIAL";
360 $self->todo($gv->CV, 0);
361 $self->walk_sub($gv->CV);
362 } elsif ($op->next->name eq "enterwrite"
363 or ($op->next->name eq "rv2gv"
364 and $op->next->next->name eq "enterwrite")) {
365 return if $self->{'forms_done'}{$$gv}++;
366 return if class($gv->FORM) eq "SPECIAL";
367 $self->todo($gv->FORM, 1);
368 $self->walk_sub($gv->FORM);
375 my ($self, $pack) = @_;
377 if (!defined $pack) {
382 $pack =~ s/(::)?$/::/;
386 my %stash = svref_2object($stash)->ARRAY;
387 while (my ($key, $val) = each %stash) {
388 next if $key eq 'main::'; # avoid infinite recursion
389 next if $key eq 'B::'; # don't automatically scan B
390 my $class = class($val);
391 if ($class eq "PV") {
393 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
394 } elsif ($class eq "IV") {
396 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
397 } elsif ($class eq "GV") {
398 if (class(my $cv = $val->CV) ne "SPECIAL") {
399 next unless $cv->FILE eq $0 || $self->{'files'}{$cv->FILE};
400 next if $self->{'subs_done'}{$$val}++;
401 $self->todo($val->CV, 0);
402 $self->walk_sub($val->CV);
404 if (class($val->FORM) ne "SPECIAL") {
405 next if $self->{'forms_done'}{$$val}++;
406 $self->todo($val->FORM, 1);
407 $self->walk_sub($val->FORM);
409 if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
410 $self->stash_subs($pack . $key);
420 foreach $ar (@{$self->{'protos_todo'}}) {
421 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
422 push @ret, "sub " . $ar->[0] . "$proto;\n";
424 delete $self->{'protos_todo'};
432 while (length($opt = substr($opts, 0, 1))) {
434 $self->{'cuddle'} = " ";
435 $opts = substr($opts, 1);
436 } elsif ($opt eq "i") {
437 $opts =~ s/^i(\d+)//;
438 $self->{'indent_size'} = $1;
439 } elsif ($opt eq "T") {
440 $self->{'use_tabs'} = 1;
441 $opts = substr($opts, 1);
442 } elsif ($opt eq "v") {
443 $opts =~ s/^v([^.]*)(.|$)//;
444 $self->{'ex_const'} = $1;
451 my $self = bless {}, $class;
452 $self->{'subs_todo'} = [];
453 $self->{'files'} = {};
454 $self->{'curstash'} = "main";
455 $self->{'curcop'} = undef;
456 $self->{'cuddle'} = "\n";
457 $self->{'indent_size'} = 4;
458 $self->{'use_tabs'} = 0;
459 $self->{'expand'} = 0;
460 $self->{'unquote'} = 0;
461 $self->{'linenums'} = 0;
462 $self->{'parens'} = 0;
463 $self->{'ex_const'} = "'???'";
465 $self->{'ambient_arybase'} = 0;
466 $self->{'ambient_warnings'} = "\0"x12;
467 $self->{'ambient_hints'} = 0;
470 while (my $arg = shift @_) {
471 if ($arg =~ /^-f(.*)/) {
472 $self->{'files'}{$1} = 1;
473 } elsif ($arg eq "-p") {
474 $self->{'parens'} = 1;
475 } elsif ($arg eq "-l") {
476 $self->{'linenums'} = 1;
477 } elsif ($arg eq "-q") {
478 $self->{'unquote'} = 1;
479 } elsif (substr($arg, 0, 2) eq "-s") {
480 $self->style_opts(substr $arg, 2);
481 } elsif ($arg =~ /^-x(\d)$/) {
482 $self->{'expand'} = $1;
489 # Mask out the bits that C<use vars> uses
490 $warnings::Bits{all} | $warnings::DeadBits{all};
493 # Initialise the contextual information, either from
494 # defaults provided with the ambient_pragmas method,
495 # or from perl's own defaults otherwise.
499 $self->{'arybase'} = $self->{'ambient_arybase'};
500 $self->{'warnings'} = $self->{'ambient_warnings'} & WARN_MASK;
501 $self->{'hints'} = $self->{'ambient_hints'} & 0xFF;
503 # also a convenient place to clear out subs_declared
504 delete $self->{'subs_declared'};
510 my $self = B::Deparse->new(@args);
511 my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
512 my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
513 my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
514 for my $block (@BEGINs, @INITs, @ENDs) {
515 if ($block->FILE eq $0 || $self->{'files'}{$block->FILE}) {
516 $self->todo($block, 0);
517 $self->walk_sub($block);
521 $self->{'curcv'} = main_cv;
522 $self->walk_sub(main_cv, main_start);
523 print $self->print_protos;
524 @{$self->{'subs_todo'}} =
525 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
526 print $self->indent($self->deparse(main_root, 0)), "\n"
527 unless null main_root;
529 while (scalar(@{$self->{'subs_todo'}})) {
530 push @text, $self->next_todo;
532 print $self->indent(join("", @text)), "\n" if @text;
539 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
542 return $self->indent($self->deparse_sub(svref_2object($sub)));
545 sub ambient_pragmas {
547 my ($arybase, $hint_bits, $warning_bits) = (0, 0, "\0"x12);
553 if ($name eq 'strict') {
556 if ($val eq 'none') {
557 $hint_bits &= ~strict::bits(qw/refs subs vars/);
563 @names = qw/refs subs vars/;
569 @names = split' ', $val;
571 $hint_bits |= strict::bits(@names);
574 elsif ($name eq '$[') {
578 elsif ($name eq 'integer'
580 || $name eq 'utf8') {
583 $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
586 $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
590 elsif ($name eq 're') {
592 if ($val eq 'none') {
593 $hint_bits &= ~re::bits(qw/taint eval asciirange/);
599 @names = qw/taint eval asciirange/;
605 @names = split' ',$val;
607 $hint_bits |= re::bits(@names);
610 elsif ($name eq 'warnings') {
611 if ($val eq 'none') {
612 $warning_bits = "\0"x12;
621 @names = split/\s+/, $val;
624 $warning_bits |= warnings::bits(@names);
627 elsif ($name eq 'warning_bits') {
628 $warning_bits = $val;
631 elsif ($name eq 'hint_bits') {
636 croak "Unknown pragma type: $name";
640 croak "The ambient_pragmas method expects an even number of args";
643 $self->{'ambient_arybase'} = $arybase;
644 $self->{'ambient_warnings'} = $warning_bits;
645 $self->{'ambient_hints'} = $hint_bits;
652 Carp::confess("Null op in deparse") if !defined($op)
653 || class($op) eq "NULL";
654 my $meth = "pp_" . $op->name;
655 return $self->$meth($op, $cx);
661 my @lines = split(/\n/, $txt);
666 my $cmd = substr($line, 0, 1);
667 if ($cmd eq "\t" or $cmd eq "\b") {
668 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
669 if ($self->{'use_tabs'}) {
670 $leader = "\t" x ($level / 8) . " " x ($level % 8);
672 $leader = " " x $level;
674 $line = substr($line, 1);
676 if (substr($line, 0, 1) eq "\f") {
677 $line = substr($line, 1); # no indent
679 $line = $leader . $line;
683 return join("\n", @lines);
690 Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
691 local $self->{'curcop'} = $self->{'curcop'};
692 if ($cv->FLAGS & SVf_POK) {
693 $proto = "(". $cv->PV . ") ";
695 if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
697 $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
698 $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
699 $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
702 local($self->{'curcv'}) = $cv;
703 local(@$self{qw'curstash warnings hints'})
704 = @$self{qw'curstash warnings hints'};
705 if (not null $cv->ROOT) {
707 return $proto . "{\n\t" .
708 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
710 my $sv = $cv->const_sv;
712 # uh-oh. inlinable sub... format it differently
713 return $proto . "{ " . const($sv) . " }\n";
714 } else { # XSUB? (or just a declaration)
723 local($self->{'curcv'}) = $form;
724 local(@$self{qw'curstash warnings hints'})
725 = @$self{'curstash warnings hints'};
726 my $op = $form->ROOT;
728 $op = $op->first->first; # skip leavewrite, lineseq
729 while (not null $op) {
730 $op = $op->sibling; # skip nextstate
732 $kid = $op->first->sibling; # skip pushmark
733 push @text, $self->const_sv($kid)->PV;
734 $kid = $kid->sibling;
735 for (; not null $kid; $kid = $kid->sibling) {
736 push @exprs, $self->deparse($kid, 0);
738 push @text, join(", ", @exprs)."\n" if @exprs;
741 return join("", @text) . ".";
746 return $op->name eq "leave" || $op->name eq "scope"
747 || $op->name eq "lineseq"
748 || ($op->name eq "null" && class($op) eq "UNOP"
749 && (is_scope($op->first) || $op->first->name eq "enter"));
753 my $name = $_[0]->name;
754 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
757 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
759 return (!null($op) and null($op->sibling)
760 and $op->name eq "null" and class($op) eq "UNOP"
761 and (($op->first->name =~ /^(and|or)$/
762 and $op->first->first->sibling->name eq "lineseq")
763 or ($op->first->name eq "lineseq"
764 and not null $op->first->first->sibling
765 and $op->first->first->sibling->name eq "unstack")
771 return ($op->name eq "rv2sv" or
772 $op->name eq "padsv" or
773 $op->name eq "gv" or # only in array/hash constructs
774 $op->flags & OPf_KIDS && !null($op->first)
775 && $op->first->name eq "gvsv");
780 my($text, $cx, $prec) = @_;
781 if ($prec < $cx # unary ops nest just fine
782 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
783 or $self->{'parens'})
786 # In a unop, let parent reuse our parens; see maybe_parens_unop
787 $text = "\cS" . $text if $cx == 16;
794 # same as above, but get around the `if it looks like a function' rule
795 sub maybe_parens_unop {
797 my($name, $kid, $cx) = @_;
798 if ($cx > 16 or $self->{'parens'}) {
799 return "$name(" . $self->deparse($kid, 1) . ")";
801 $kid = $self->deparse($kid, 16);
802 if (substr($kid, 0, 1) eq "\cS") {
804 return $name . substr($kid, 1);
805 } elsif (substr($kid, 0, 1) eq "(") {
806 # avoid looks-like-a-function trap with extra parens
807 # (`+' can lead to ambiguities)
808 return "$name(" . $kid . ")";
815 sub maybe_parens_func {
817 my($func, $text, $cx, $prec) = @_;
818 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
819 return "$func($text)";
821 return "$func $text";
827 my($op, $cx, $text) = @_;
828 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
829 if (want_scalar($op)) {
830 return "local $text";
832 return $self->maybe_parens_func("local", $text, $cx, 16);
841 my($op, $cx, $func, @args) = @_;
842 if ($op->private & OPpTARGET_MY) {
843 my $var = $self->padname($op->targ);
844 my $val = $func->($self, $op, 7, @args);
845 return $self->maybe_parens("$var = $val", $cx, 7);
847 return $func->($self, $op, $cx, @args);
854 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
859 my($op, $cx, $text) = @_;
860 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
861 if (want_scalar($op)) {
864 return $self->maybe_parens_func("my", $text, $cx, 16);
871 # The following OPs don't have functions:
873 # pp_padany -- does not exist after parsing
874 # pp_rcatline -- does not exist
876 sub pp_enter { # see also leave
877 cluck "unexpected OP_ENTER";
881 sub pp_pushmark { # see also list
882 cluck "unexpected OP_PUSHMARK";
886 sub pp_leavesub { # see also deparse_sub
887 cluck "unexpected OP_LEAVESUB";
891 sub pp_leavewrite { # see also deparse_format
892 cluck "unexpected OP_LEAVEWRITE";
896 sub pp_method { # see also entersub
897 cluck "unexpected OP_METHOD";
901 sub pp_regcmaybe { # see also regcomp
902 cluck "unexpected OP_REGCMAYBE";
906 sub pp_regcreset { # see also regcomp
907 cluck "unexpected OP_REGCRESET";
911 sub pp_substcont { # see also subst
912 cluck "unexpected OP_SUBSTCONT";
916 sub pp_grepstart { # see also grepwhile
917 cluck "unexpected OP_GREPSTART";
921 sub pp_mapstart { # see also mapwhile
922 cluck "unexpected OP_MAPSTART";
926 sub pp_flip { # see also flop
927 cluck "unexpected OP_FLIP";
931 sub pp_iter { # see also leaveloop
932 cluck "unexpected OP_ITER";
936 sub pp_enteriter { # see also leaveloop
937 cluck "unexpected OP_ENTERITER";
941 sub pp_enterloop { # see also leaveloop
942 cluck "unexpected OP_ENTERLOOP";
946 sub pp_leaveeval { # see also entereval
947 cluck "unexpected OP_LEAVEEVAL";
951 sub pp_entertry { # see also leavetry
952 cluck "unexpected OP_ENTERTRY";
960 for (my $i = 0; $i < @ops; $i++) {
962 if (is_state $ops[$i]) {
963 $expr = $self->deparse($ops[$i], 0);
967 if (!is_state $ops[$i] and $ops[$i+1] and !null($ops[$i+1]) and
968 $ops[$i+1]->name eq "leaveloop" and $self->{'expand'} < 3)
970 push @exprs, $expr . $self->for_loop($ops[$i], 0);
974 $expr .= $self->deparse($ops[$i], 0);
975 push @exprs, $expr if length $expr;
977 for(@exprs[0..@exprs-1]) { s/;\n\z// }
978 return join(";\n", @exprs);
982 my($real_block, $self, $op, $cx) = @_;
986 local(@$self{qw'curstash warnings hints'})
987 = @$self{qw'curstash warnings hints'} if $real_block;
989 $kid = $op->first->sibling; # skip enter
990 if (is_miniwhile($kid)) {
991 my $top = $kid->first;
992 my $name = $top->name;
993 if ($name eq "and") {
995 } elsif ($name eq "or") {
997 } else { # no conditional -> while 1 or until 0
998 return $self->deparse($top->first, 1) . " while 1";
1000 my $cond = $top->first;
1001 my $body = $cond->sibling->first; # skip lineseq
1002 $cond = $self->deparse($cond, 1);
1003 $body = $self->deparse($body, 1);
1004 return "$body $name $cond";
1009 for (; !null($kid); $kid = $kid->sibling) {
1012 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
1013 return "do { " . $self->lineseq(@kids) . " }";
1015 my $lineseq = $self->lineseq(@kids);
1016 return (length ($lineseq) ? "$lineseq;" : "");
1020 sub pp_scope { scopeop(0, @_); }
1021 sub pp_lineseq { scopeop(0, @_); }
1022 sub pp_leave { scopeop(1, @_); }
1024 # The BEGIN {} is used here because otherwise this code isn't executed
1025 # when you run B::Deparse on itself.
1027 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
1028 "ENV", "ARGV", "ARGVOUT", "_"); }
1033 Carp::confess() if $gv->isa("B::CV");
1034 my $stash = $gv->STASH->NAME;
1035 my $name = $gv->SAFENAME;
1036 if ($stash eq $self->{'curstash'} or $globalnames{$name}
1037 or $name =~ /^[^A-Za-z_]/)
1041 $stash = $stash . "::";
1043 if ($name =~ /^\^../) {
1044 $name = "{$name}"; # ${^WARNING_BITS} etc
1046 return $stash . $name;
1049 # Recurses down the tree, looking for a COP
1051 my ($self, $op) = @_;
1052 if ($op->flags & OPf_KIDS) {
1053 for (my $o=$op->first; $$o; $o=$o->sibling) {
1054 return $o if is_state($o);
1055 my $r = $self->find_cop($o);
1056 return $r if defined $r;
1062 # Returns a list of subs which should be inserted before the COP
1064 my ($self, $op, $out_seq) = @_;
1065 my $seq = $op->cop_seq;
1066 # If we have nephews, then our sequence number indicates
1067 # the cop_seq of the end of some sort of scope.
1068 if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
1069 and my $ncop = $self->find_cop($op->sibling)) {
1070 $seq = $ncop->cop_seq;
1072 $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
1073 return $self->seq_subs($seq);
1077 my ($self, $seq) = @_;
1079 #push @text, "# ($seq)\n";
1081 while (scalar(@{$self->{'subs_todo'}})
1082 and $seq > $self->{'subs_todo'}[0][0]) {
1083 push @text, $self->next_todo;
1088 # Notice how subs and formats are inserted between statements here;
1089 # also $[ assignments and pragmas.
1093 $self->{'curcop'} = $op;
1095 @text = $op->label . ": " if $op->label;
1096 #push @text, "# ", $op->cop_seq, "\n";
1097 push @text, $self->cop_subs($op);
1098 my $stash = $op->stashpv;
1099 if ($stash ne $self->{'curstash'}) {
1100 push @text, "package $stash;\n";
1101 $self->{'curstash'} = $stash;
1103 if ($self->{'linenums'}) {
1104 push @text, "\f#line " . $op->line .
1105 ' "' . $op->file, qq'"\n';
1108 if ($self->{'arybase'} != $op->arybase) {
1109 push @text, '$[ = '. $op->arybase .";\n";
1110 $self->{'arybase'} = $op->arybase;
1113 my $warnings = $op->warnings;
1115 if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
1116 $warning_bits = $warnings::Bits{"all"};
1118 elsif ($warnings->isa("B::SPECIAL")) {
1119 $warning_bits = "\0"x12;
1122 $warning_bits = $warnings->PV & WARN_MASK;
1125 if ($self->{'warnings'} ne $warning_bits) {
1126 push @text, declare_warnings($self->{'warnings'}, $warning_bits);
1127 $self->{'warnings'} = $warning_bits;
1130 if ($self->{'hints'} != $op->private) {
1131 push @text, declare_hints($self->{'hints'}, $op->private);
1132 $self->{'hints'} = $op->private;
1135 return join("", @text);
1138 sub declare_warnings {
1139 my ($from, $to) = @_;
1140 if ($to eq warnings::bits("all")) {
1141 return "use warnings;\n";
1143 elsif ($to eq "\0"x12) {
1144 return "no warnings;\n";
1146 return "BEGIN {\${^WARNING_BITS} = ".cstring($to)."}\n";
1150 my ($from, $to) = @_;
1152 return sprintf "BEGIN {\$^H &= ~0xFF; \$^H |= %x}\n", $bits;
1155 sub pp_dbstate { pp_nextstate(@_) }
1156 sub pp_setstate { pp_nextstate(@_) }
1158 sub pp_unstack { return "" } # see also leaveloop
1162 my($op, $cx, $name) = @_;
1166 sub pp_stub { baseop(@_, "()") }
1167 sub pp_wantarray { baseop(@_, "wantarray") }
1168 sub pp_fork { baseop(@_, "fork") }
1169 sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
1170 sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
1171 sub pp_time { maybe_targmy(@_, \&baseop, "time") }
1172 sub pp_tms { baseop(@_, "times") }
1173 sub pp_ghostent { baseop(@_, "gethostent") }
1174 sub pp_gnetent { baseop(@_, "getnetent") }
1175 sub pp_gprotoent { baseop(@_, "getprotoent") }
1176 sub pp_gservent { baseop(@_, "getservent") }
1177 sub pp_ehostent { baseop(@_, "endhostent") }
1178 sub pp_enetent { baseop(@_, "endnetent") }
1179 sub pp_eprotoent { baseop(@_, "endprotoent") }
1180 sub pp_eservent { baseop(@_, "endservent") }
1181 sub pp_gpwent { baseop(@_, "getpwent") }
1182 sub pp_spwent { baseop(@_, "setpwent") }
1183 sub pp_epwent { baseop(@_, "endpwent") }
1184 sub pp_ggrent { baseop(@_, "getgrent") }
1185 sub pp_sgrent { baseop(@_, "setgrent") }
1186 sub pp_egrent { baseop(@_, "endgrent") }
1187 sub pp_getlogin { baseop(@_, "getlogin") }
1189 sub POSTFIX () { 1 }
1191 # I couldn't think of a good short name, but this is the category of
1192 # symbolic unary operators with interesting precedence
1196 my($op, $cx, $name, $prec, $flags) = (@_, 0);
1197 my $kid = $op->first;
1198 $kid = $self->deparse($kid, $prec);
1199 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
1203 sub pp_preinc { pfixop(@_, "++", 23) }
1204 sub pp_predec { pfixop(@_, "--", 23) }
1205 sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1206 sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1207 sub pp_i_preinc { pfixop(@_, "++", 23) }
1208 sub pp_i_predec { pfixop(@_, "--", 23) }
1209 sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
1210 sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
1211 sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
1213 sub pp_negate { maybe_targmy(@_, \&real_negate) }
1217 if ($op->first->name =~ /^(i_)?negate$/) {
1219 $self->pfixop($op, $cx, "-", 21.5);
1221 $self->pfixop($op, $cx, "-", 21);
1224 sub pp_i_negate { pp_negate(@_) }
1230 $self->pfixop($op, $cx, "not ", 4);
1232 $self->pfixop($op, $cx, "!", 21);
1238 my($op, $cx, $name) = @_;
1240 if ($op->flags & OPf_KIDS) {
1242 return $self->maybe_parens_unop($name, $kid, $cx);
1244 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1248 sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
1249 sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
1250 sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
1251 sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
1252 sub pp_defined { unop(@_, "defined") }
1253 sub pp_undef { unop(@_, "undef") }
1254 sub pp_study { unop(@_, "study") }
1255 sub pp_ref { unop(@_, "ref") }
1256 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
1258 sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
1259 sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
1260 sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
1261 sub pp_srand { unop(@_, "srand") }
1262 sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
1263 sub pp_log { maybe_targmy(@_, \&unop, "log") }
1264 sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
1265 sub pp_int { maybe_targmy(@_, \&unop, "int") }
1266 sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
1267 sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
1268 sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
1270 sub pp_length { maybe_targmy(@_, \&unop, "length") }
1271 sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
1272 sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
1274 sub pp_each { unop(@_, "each") }
1275 sub pp_values { unop(@_, "values") }
1276 sub pp_keys { unop(@_, "keys") }
1277 sub pp_pop { unop(@_, "pop") }
1278 sub pp_shift { unop(@_, "shift") }
1280 sub pp_caller { unop(@_, "caller") }
1281 sub pp_reset { unop(@_, "reset") }
1282 sub pp_exit { unop(@_, "exit") }
1283 sub pp_prototype { unop(@_, "prototype") }
1285 sub pp_close { unop(@_, "close") }
1286 sub pp_fileno { unop(@_, "fileno") }
1287 sub pp_umask { unop(@_, "umask") }
1288 sub pp_untie { unop(@_, "untie") }
1289 sub pp_tied { unop(@_, "tied") }
1290 sub pp_dbmclose { unop(@_, "dbmclose") }
1291 sub pp_getc { unop(@_, "getc") }
1292 sub pp_eof { unop(@_, "eof") }
1293 sub pp_tell { unop(@_, "tell") }
1294 sub pp_getsockname { unop(@_, "getsockname") }
1295 sub pp_getpeername { unop(@_, "getpeername") }
1297 sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
1298 sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
1299 sub pp_readlink { unop(@_, "readlink") }
1300 sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
1301 sub pp_readdir { unop(@_, "readdir") }
1302 sub pp_telldir { unop(@_, "telldir") }
1303 sub pp_rewinddir { unop(@_, "rewinddir") }
1304 sub pp_closedir { unop(@_, "closedir") }
1305 sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
1306 sub pp_localtime { unop(@_, "localtime") }
1307 sub pp_gmtime { unop(@_, "gmtime") }
1308 sub pp_alarm { unop(@_, "alarm") }
1309 sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
1311 sub pp_dofile { unop(@_, "do") }
1312 sub pp_entereval { unop(@_, "eval") }
1314 sub pp_ghbyname { unop(@_, "gethostbyname") }
1315 sub pp_gnbyname { unop(@_, "getnetbyname") }
1316 sub pp_gpbyname { unop(@_, "getprotobyname") }
1317 sub pp_shostent { unop(@_, "sethostent") }
1318 sub pp_snetent { unop(@_, "setnetent") }
1319 sub pp_sprotoent { unop(@_, "setprotoent") }
1320 sub pp_sservent { unop(@_, "setservent") }
1321 sub pp_gpwnam { unop(@_, "getpwnam") }
1322 sub pp_gpwuid { unop(@_, "getpwuid") }
1323 sub pp_ggrnam { unop(@_, "getgrnam") }
1324 sub pp_ggrgid { unop(@_, "getgrgid") }
1326 sub pp_lock { unop(@_, "lock") }
1332 if ($op->private & OPpEXISTS_SUB) {
1333 # Checking for the existence of a subroutine
1334 return $self->maybe_parens_func("exists",
1335 $self->pp_rv2cv($op->first, 16), $cx, 16);
1337 if ($op->flags & OPf_SPECIAL) {
1338 # Array element, not hash element
1339 return $self->maybe_parens_func("exists",
1340 $self->pp_aelem($op->first, 16), $cx, 16);
1342 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
1350 if ($op->private & OPpSLICE) {
1351 if ($op->flags & OPf_SPECIAL) {
1352 # Deleting from an array, not a hash
1353 return $self->maybe_parens_func("delete",
1354 $self->pp_aslice($op->first, 16),
1357 return $self->maybe_parens_func("delete",
1358 $self->pp_hslice($op->first, 16),
1361 if ($op->flags & OPf_SPECIAL) {
1362 # Deleting from an array, not a hash
1363 return $self->maybe_parens_func("delete",
1364 $self->pp_aelem($op->first, 16),
1367 return $self->maybe_parens_func("delete",
1368 $self->pp_helem($op->first, 16),
1376 if (class($op) eq "UNOP" and $op->first->name eq "const"
1377 and $op->first->private & OPpCONST_BARE)
1379 my $name = $self->const_sv($op->first)->PV;
1382 return "require $name";
1384 $self->unop($op, $cx, "require");
1391 my $kid = $op->first;
1392 if (not null $kid->sibling) {
1393 # XXX Was a here-doc
1394 return $self->dquote($op);
1396 $self->unop(@_, "scalar");
1403 #cluck "curcv was undef" unless $self->{curcv};
1404 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
1410 my $kid = $op->first;
1411 if ($kid->name eq "null") {
1413 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1414 my($pre, $post) = @{{"anonlist" => ["[","]"],
1415 "anonhash" => ["{","}"]}->{$kid->name}};
1417 $kid = $kid->first->sibling; # skip pushmark
1418 for (; !null($kid); $kid = $kid->sibling) {
1419 $expr = $self->deparse($kid, 6);
1422 return $pre . join(", ", @exprs) . $post;
1423 } elsif (!null($kid->sibling) and
1424 $kid->sibling->name eq "anoncode") {
1426 $self->deparse_sub($self->padval($kid->sibling->targ));
1427 } elsif ($kid->name eq "pushmark") {
1428 my $sib_name = $kid->sibling->name;
1429 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1430 and not $kid->sibling->flags & OPf_REF)
1432 # The @a in \(@a) isn't in ref context, but only when the
1434 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1435 } elsif ($sib_name eq 'entersub') {
1436 my $text = $self->deparse($kid->sibling, 1);
1437 # Always show parens for \(&func()), but only with -p otherwise
1438 $text = "($text)" if $self->{'parens'}
1439 or $kid->sibling->private & OPpENTERSUB_AMPER;
1444 $self->pfixop($op, $cx, "\\", 20);
1447 sub pp_srefgen { pp_refgen(@_) }
1452 my $kid = $op->first;
1453 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1454 return "<" . $self->deparse($kid, 1) . ">";
1457 # Unary operators that can occur as pseudo-listops inside double quotes
1460 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1462 if ($op->flags & OPf_KIDS) {
1464 # If there's more than one kid, the first is an ex-pushmark.
1465 $kid = $kid->sibling if not null $kid->sibling;
1466 return $self->maybe_parens_unop($name, $kid, $cx);
1468 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1472 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1473 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1474 sub pp_uc { dq_unop(@_, "uc") }
1475 sub pp_lc { dq_unop(@_, "lc") }
1476 sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
1480 my ($op, $cx, $name) = @_;
1481 if (class($op) eq "PVOP") {
1482 return "$name " . $op->pv;
1483 } elsif (class($op) eq "OP") {
1485 } elsif (class($op) eq "UNOP") {
1486 # Note -- loop exits are actually exempt from the
1487 # looks-like-a-func rule, but a few extra parens won't hurt
1488 return $self->maybe_parens_unop($name, $op->first, $cx);
1492 sub pp_last { loopex(@_, "last") }
1493 sub pp_next { loopex(@_, "next") }
1494 sub pp_redo { loopex(@_, "redo") }
1495 sub pp_goto { loopex(@_, "goto") }
1496 sub pp_dump { loopex(@_, "dump") }
1500 my($op, $cx, $name) = @_;
1501 if (class($op) eq "UNOP") {
1502 # Genuine `-X' filetests are exempt from the LLAFR, but not
1503 # l?stat(); for the sake of clarity, give'em all parens
1504 return $self->maybe_parens_unop($name, $op->first, $cx);
1505 } elsif (class($op) eq "SVOP") {
1506 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1507 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1512 sub pp_lstat { ftst(@_, "lstat") }
1513 sub pp_stat { ftst(@_, "stat") }
1514 sub pp_ftrread { ftst(@_, "-R") }
1515 sub pp_ftrwrite { ftst(@_, "-W") }
1516 sub pp_ftrexec { ftst(@_, "-X") }
1517 sub pp_fteread { ftst(@_, "-r") }
1518 sub pp_ftewrite { ftst(@_, "-r") }
1519 sub pp_fteexec { ftst(@_, "-r") }
1520 sub pp_ftis { ftst(@_, "-e") }
1521 sub pp_fteowned { ftst(@_, "-O") }
1522 sub pp_ftrowned { ftst(@_, "-o") }
1523 sub pp_ftzero { ftst(@_, "-z") }
1524 sub pp_ftsize { ftst(@_, "-s") }
1525 sub pp_ftmtime { ftst(@_, "-M") }
1526 sub pp_ftatime { ftst(@_, "-A") }
1527 sub pp_ftctime { ftst(@_, "-C") }
1528 sub pp_ftsock { ftst(@_, "-S") }
1529 sub pp_ftchr { ftst(@_, "-c") }
1530 sub pp_ftblk { ftst(@_, "-b") }
1531 sub pp_ftfile { ftst(@_, "-f") }
1532 sub pp_ftdir { ftst(@_, "-d") }
1533 sub pp_ftpipe { ftst(@_, "-p") }
1534 sub pp_ftlink { ftst(@_, "-l") }
1535 sub pp_ftsuid { ftst(@_, "-u") }
1536 sub pp_ftsgid { ftst(@_, "-g") }
1537 sub pp_ftsvtx { ftst(@_, "-k") }
1538 sub pp_fttty { ftst(@_, "-t") }
1539 sub pp_fttext { ftst(@_, "-T") }
1540 sub pp_ftbinary { ftst(@_, "-B") }
1542 sub SWAP_CHILDREN () { 1 }
1543 sub ASSIGN () { 2 } # has OP= variant
1549 my $name = $op->name;
1550 if ($name eq "concat" and $op->first->name eq "concat") {
1551 # avoid spurious `=' -- see comment in pp_concat
1554 if ($name eq "null" and class($op) eq "UNOP"
1555 and $op->first->name =~ /^(and|x?or)$/
1556 and null $op->first->sibling)
1558 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1559 # with a null that's used as the common end point of the two
1560 # flows of control. For precedence purposes, ignore it.
1561 # (COND_EXPRs have these too, but we don't bother with
1562 # their associativity).
1563 return assoc_class($op->first);
1565 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1568 # Left associative operators, like `+', for which
1569 # $a + $b + $c is equivalent to ($a + $b) + $c
1572 %left = ('multiply' => 19, 'i_multiply' => 19,
1573 'divide' => 19, 'i_divide' => 19,
1574 'modulo' => 19, 'i_modulo' => 19,
1576 'add' => 18, 'i_add' => 18,
1577 'subtract' => 18, 'i_subtract' => 18,
1579 'left_shift' => 17, 'right_shift' => 17,
1581 'bit_or' => 12, 'bit_xor' => 12,
1583 'or' => 2, 'xor' => 2,
1587 sub deparse_binop_left {
1589 my($op, $left, $prec) = @_;
1590 if ($left{assoc_class($op)} && $left{assoc_class($left)}
1591 and $left{assoc_class($op)} == $left{assoc_class($left)})
1593 return $self->deparse($left, $prec - .00001);
1595 return $self->deparse($left, $prec);
1599 # Right associative operators, like `=', for which
1600 # $a = $b = $c is equivalent to $a = ($b = $c)
1603 %right = ('pow' => 22,
1604 'sassign=' => 7, 'aassign=' => 7,
1605 'multiply=' => 7, 'i_multiply=' => 7,
1606 'divide=' => 7, 'i_divide=' => 7,
1607 'modulo=' => 7, 'i_modulo=' => 7,
1609 'add=' => 7, 'i_add=' => 7,
1610 'subtract=' => 7, 'i_subtract=' => 7,
1612 'left_shift=' => 7, 'right_shift=' => 7,
1614 'bit_or=' => 7, 'bit_xor=' => 7,
1620 sub deparse_binop_right {
1622 my($op, $right, $prec) = @_;
1623 if ($right{assoc_class($op)} && $right{assoc_class($right)}
1624 and $right{assoc_class($op)} == $right{assoc_class($right)})
1626 return $self->deparse($right, $prec - .00001);
1628 return $self->deparse($right, $prec);
1634 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1635 my $left = $op->first;
1636 my $right = $op->last;
1638 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1642 if ($flags & SWAP_CHILDREN) {
1643 ($left, $right) = ($right, $left);
1645 $left = $self->deparse_binop_left($op, $left, $prec);
1646 $right = $self->deparse_binop_right($op, $right, $prec);
1647 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1650 sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1651 sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1652 sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
1653 sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1654 sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1655 sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
1656 sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
1657 sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
1658 sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
1659 sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
1660 sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
1662 sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
1663 sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
1664 sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
1665 sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
1666 sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
1668 sub pp_eq { binop(@_, "==", 14) }
1669 sub pp_ne { binop(@_, "!=", 14) }
1670 sub pp_lt { binop(@_, "<", 15) }
1671 sub pp_gt { binop(@_, ">", 15) }
1672 sub pp_ge { binop(@_, ">=", 15) }
1673 sub pp_le { binop(@_, "<=", 15) }
1674 sub pp_ncmp { binop(@_, "<=>", 14) }
1675 sub pp_i_eq { binop(@_, "==", 14) }
1676 sub pp_i_ne { binop(@_, "!=", 14) }
1677 sub pp_i_lt { binop(@_, "<", 15) }
1678 sub pp_i_gt { binop(@_, ">", 15) }
1679 sub pp_i_ge { binop(@_, ">=", 15) }
1680 sub pp_i_le { binop(@_, "<=", 15) }
1681 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1683 sub pp_seq { binop(@_, "eq", 14) }
1684 sub pp_sne { binop(@_, "ne", 14) }
1685 sub pp_slt { binop(@_, "lt", 15) }
1686 sub pp_sgt { binop(@_, "gt", 15) }
1687 sub pp_sge { binop(@_, "ge", 15) }
1688 sub pp_sle { binop(@_, "le", 15) }
1689 sub pp_scmp { binop(@_, "cmp", 14) }
1691 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1692 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1694 # `.' is special because concats-of-concats are optimized to save copying
1695 # by making all but the first concat stacked. The effect is as if the
1696 # programmer had written `($a . $b) .= $c', except legal.
1697 sub pp_concat { maybe_targmy(@_, \&real_concat) }
1701 my $left = $op->first;
1702 my $right = $op->last;
1705 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1709 $left = $self->deparse_binop_left($op, $left, $prec);
1710 $right = $self->deparse_binop_right($op, $right, $prec);
1711 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1714 # `x' is weird when the left arg is a list
1718 my $left = $op->first;
1719 my $right = $op->last;
1722 if ($op->flags & OPf_STACKED) {
1726 if (null($right)) { # list repeat; count is inside left-side ex-list
1727 my $kid = $left->first->sibling; # skip pushmark
1729 for (; !null($kid->sibling); $kid = $kid->sibling) {
1730 push @exprs, $self->deparse($kid, 6);
1733 $left = "(" . join(", ", @exprs). ")";
1735 $left = $self->deparse_binop_left($op, $left, $prec);
1737 $right = $self->deparse_binop_right($op, $right, $prec);
1738 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1743 my ($op, $cx, $type) = @_;
1744 my $left = $op->first;
1745 my $right = $left->sibling;
1746 $left = $self->deparse($left, 9);
1747 $right = $self->deparse($right, 9);
1748 return $self->maybe_parens("$left $type $right", $cx, 9);
1754 my $flip = $op->first;
1755 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1756 return $self->range($flip->first, $cx, $type);
1759 # one-line while/until is handled in pp_leave
1763 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1764 my $left = $op->first;
1765 my $right = $op->first->sibling;
1766 if ($cx == 0 and is_scope($right) and $blockname
1767 and $self->{'expand'} < 7)
1769 $left = $self->deparse($left, 1);
1770 $right = $self->deparse($right, 0);
1771 return "$blockname ($left) {\n\t$right\n\b}\cK";
1772 } elsif ($cx == 0 and $blockname and not $self->{'parens'}
1773 and $self->{'expand'} < 7) { # $b if $a
1774 $right = $self->deparse($right, 1);
1775 $left = $self->deparse($left, 1);
1776 return "$right $blockname $left";
1777 } elsif ($cx > $lowprec and $highop) { # $a && $b
1778 $left = $self->deparse_binop_left($op, $left, $highprec);
1779 $right = $self->deparse_binop_right($op, $right, $highprec);
1780 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1781 } else { # $a and $b
1782 $left = $self->deparse_binop_left($op, $left, $lowprec);
1783 $right = $self->deparse_binop_right($op, $right, $lowprec);
1784 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1788 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1789 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1791 # xor is syntactically a logop, but it's really a binop (contrary to
1792 # old versions of opcode.pl). Syntax is what matters here.
1793 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1797 my ($op, $cx, $opname) = @_;
1798 my $left = $op->first;
1799 my $right = $op->first->sibling->first; # skip sassign
1800 $left = $self->deparse($left, 7);
1801 $right = $self->deparse($right, 7);
1802 return $self->maybe_parens("$left $opname $right", $cx, 7);
1805 sub pp_andassign { logassignop(@_, "&&=") }
1806 sub pp_orassign { logassignop(@_, "||=") }
1810 my($op, $cx, $name) = @_;
1812 my $parens = ($cx >= 5) || $self->{'parens'};
1813 my $kid = $op->first->sibling;
1814 return $name if null $kid;
1815 my $first = $self->deparse($kid, 6);
1816 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1817 push @exprs, $first;
1818 $kid = $kid->sibling;
1819 for (; !null($kid); $kid = $kid->sibling) {
1820 push @exprs, $self->deparse($kid, 6);
1823 return "$name(" . join(", ", @exprs) . ")";
1825 return "$name " . join(", ", @exprs);
1829 sub pp_bless { listop(@_, "bless") }
1830 sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
1831 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1832 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1833 sub pp_index { maybe_targmy(@_, \&listop, "index") }
1834 sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
1835 sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
1836 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1837 sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
1838 sub pp_unpack { listop(@_, "unpack") }
1839 sub pp_pack { listop(@_, "pack") }
1840 sub pp_join { maybe_targmy(@_, \&listop, "join") }
1841 sub pp_splice { listop(@_, "splice") }
1842 sub pp_push { maybe_targmy(@_, \&listop, "push") }
1843 sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
1844 sub pp_reverse { listop(@_, "reverse") }
1845 sub pp_warn { listop(@_, "warn") }
1846 sub pp_die { listop(@_, "die") }
1847 # Actually, return is exempt from the LLAFR (see examples in this very
1848 # module!), but for consistency's sake, ignore that fact
1849 sub pp_return { listop(@_, "return") }
1850 sub pp_open { listop(@_, "open") }
1851 sub pp_pipe_op { listop(@_, "pipe") }
1852 sub pp_tie { listop(@_, "tie") }
1853 sub pp_binmode { listop(@_, "binmode") }
1854 sub pp_dbmopen { listop(@_, "dbmopen") }
1855 sub pp_sselect { listop(@_, "select") }
1856 sub pp_select { listop(@_, "select") }
1857 sub pp_read { listop(@_, "read") }
1858 sub pp_sysopen { listop(@_, "sysopen") }
1859 sub pp_sysseek { listop(@_, "sysseek") }
1860 sub pp_sysread { listop(@_, "sysread") }
1861 sub pp_syswrite { listop(@_, "syswrite") }
1862 sub pp_send { listop(@_, "send") }
1863 sub pp_recv { listop(@_, "recv") }
1864 sub pp_seek { listop(@_, "seek") }
1865 sub pp_fcntl { listop(@_, "fcntl") }
1866 sub pp_ioctl { listop(@_, "ioctl") }
1867 sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
1868 sub pp_socket { listop(@_, "socket") }
1869 sub pp_sockpair { listop(@_, "sockpair") }
1870 sub pp_bind { listop(@_, "bind") }
1871 sub pp_connect { listop(@_, "connect") }
1872 sub pp_listen { listop(@_, "listen") }
1873 sub pp_accept { listop(@_, "accept") }
1874 sub pp_shutdown { listop(@_, "shutdown") }
1875 sub pp_gsockopt { listop(@_, "getsockopt") }
1876 sub pp_ssockopt { listop(@_, "setsockopt") }
1877 sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
1878 sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
1879 sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
1880 sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
1881 sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
1882 sub pp_link { maybe_targmy(@_, \&listop, "link") }
1883 sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
1884 sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
1885 sub pp_open_dir { listop(@_, "opendir") }
1886 sub pp_seekdir { listop(@_, "seekdir") }
1887 sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
1888 sub pp_system { maybe_targmy(@_, \&listop, "system") }
1889 sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
1890 sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
1891 sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
1892 sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
1893 sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
1894 sub pp_shmget { listop(@_, "shmget") }
1895 sub pp_shmctl { listop(@_, "shmctl") }
1896 sub pp_shmread { listop(@_, "shmread") }
1897 sub pp_shmwrite { listop(@_, "shmwrite") }
1898 sub pp_msgget { listop(@_, "msgget") }
1899 sub pp_msgctl { listop(@_, "msgctl") }
1900 sub pp_msgsnd { listop(@_, "msgsnd") }
1901 sub pp_msgrcv { listop(@_, "msgrcv") }
1902 sub pp_semget { listop(@_, "semget") }
1903 sub pp_semctl { listop(@_, "semctl") }
1904 sub pp_semop { listop(@_, "semop") }
1905 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1906 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1907 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1908 sub pp_gsbyname { listop(@_, "getservbyname") }
1909 sub pp_gsbyport { listop(@_, "getservbyport") }
1910 sub pp_syscall { listop(@_, "syscall") }
1915 my $text = $self->dq($op->first->sibling); # skip pushmark
1916 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1917 or $text =~ /[<>]/) {
1918 return 'glob(' . single_delim('qq', '"', $text) . ')';
1920 return '<' . $text . '>';
1924 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1925 # be a filehandle. This could probably be better fixed in the core
1926 # by moving the GV lookup into ck_truc.
1932 my $parens = ($cx >= 5) || $self->{'parens'};
1933 my $kid = $op->first->sibling;
1935 if ($op->flags & OPf_SPECIAL) {
1936 # $kid is an OP_CONST
1937 $fh = $self->const_sv($kid)->PV;
1939 $fh = $self->deparse($kid, 6);
1940 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1942 my $len = $self->deparse($kid->sibling, 6);
1944 return "truncate($fh, $len)";
1946 return "truncate $fh, $len";
1952 my($op, $cx, $name) = @_;
1954 my $kid = $op->first->sibling;
1956 if ($op->flags & OPf_STACKED) {
1958 $indir = $indir->first; # skip rv2gv
1959 if (is_scope($indir)) {
1960 $indir = "{" . $self->deparse($indir, 0) . "}";
1962 $indir = $self->deparse($indir, 24);
1964 $indir = $indir . " ";
1965 $kid = $kid->sibling;
1967 for (; !null($kid); $kid = $kid->sibling) {
1968 $expr = $self->deparse($kid, 6);
1971 return $self->maybe_parens_func($name, $indir . join(", ", @exprs),
1975 sub pp_prtf { indirop(@_, "printf") }
1976 sub pp_print { indirop(@_, "print") }
1977 sub pp_sort { indirop(@_, "sort") }
1981 my($op, $cx, $name) = @_;
1983 my $kid = $op->first; # this is the (map|grep)start
1984 $kid = $kid->first->sibling; # skip a pushmark
1985 my $code = $kid->first; # skip a null
1986 if (is_scope $code) {
1987 $code = "{" . $self->deparse($code, 0) . "} ";
1989 $code = $self->deparse($code, 24) . ", ";
1991 $kid = $kid->sibling;
1992 for (; !null($kid); $kid = $kid->sibling) {
1993 $expr = $self->deparse($kid, 6);
1994 push @exprs, $expr if $expr;
1996 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1999 sub pp_mapwhile { mapop(@_, "map") }
2000 sub pp_grepwhile { mapop(@_, "grep") }
2006 my $kid = $op->first->sibling; # skip pushmark
2008 my $local = "either"; # could be local(...) or my(...)
2009 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
2010 # This assumes that no other private flags equal 128, and that
2011 # OPs that store things other than flags in their op_private,
2012 # like OP_AELEMFAST, won't be immediate children of a list.
2013 unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
2015 $local = ""; # or not
2018 if ($lop->name =~ /^pad[ash]v$/) { # my()
2019 ($local = "", last) if $local eq "local";
2021 } elsif ($lop->name ne "undef") { # local()
2022 ($local = "", last) if $local eq "my";
2026 $local = "" if $local eq "either"; # no point if it's all undefs
2027 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
2028 for (; !null($kid); $kid = $kid->sibling) {
2030 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
2035 $self->{'avoid_local'}{$$lop}++;
2036 $expr = $self->deparse($kid, 6);
2037 delete $self->{'avoid_local'}{$$lop};
2039 $expr = $self->deparse($kid, 6);
2044 return "$local(" . join(", ", @exprs) . ")";
2046 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
2050 sub is_ifelse_cont {
2052 return ($op->name eq "null" and class($op) eq "UNOP"
2053 and $op->first->name =~ /^(and|cond_expr)$/
2054 and is_scope($op->first->first->sibling));
2060 my $cond = $op->first;
2061 my $true = $cond->sibling;
2062 my $false = $true->sibling;
2063 my $cuddle = $self->{'cuddle'};
2064 unless ($cx == 0 and (is_scope($true) and $true->name ne "null") and
2065 (is_scope($false) || is_ifelse_cont($false))
2066 and $self->{'expand'} < 7) {
2067 $cond = $self->deparse($cond, 8);
2068 $true = $self->deparse($true, 8);
2069 $false = $self->deparse($false, 8);
2070 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
2073 $cond = $self->deparse($cond, 1);
2074 $true = $self->deparse($true, 0);
2075 my $head = "if ($cond) {\n\t$true\n\b}";
2077 while (!null($false) and is_ifelse_cont($false)) {
2078 my $newop = $false->first;
2079 my $newcond = $newop->first;
2080 my $newtrue = $newcond->sibling;
2081 $false = $newtrue->sibling; # last in chain is OP_AND => no else
2082 $newcond = $self->deparse($newcond, 1);
2083 $newtrue = $self->deparse($newtrue, 0);
2084 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
2086 if (!null($false)) {
2087 $false = $cuddle . "else {\n\t" .
2088 $self->deparse($false, 0) . "\n\b}\cK";
2092 return $head . join($cuddle, "", @elsifs) . $false;
2097 my($op, $cx, $init) = @_;
2098 my $enter = $op->first;
2099 my $kid = $enter->sibling;
2100 local(@$self{qw'curstash warnings hints'})
2101 = @$self{qw'curstash warnings hints'};
2106 my $out_seq = $self->{'curcop'}->cop_seq;;
2107 if ($kid->name eq "lineseq") { # bare or infinite loop
2108 if (is_state $kid->last) { # infinite
2109 $head = "for (;;) "; # shorter than while (1)
2115 } elsif ($enter->name eq "enteriter") { # foreach
2116 my $ary = $enter->first->sibling; # first was pushmark
2117 my $var = $ary->sibling;
2118 if ($enter->flags & OPf_STACKED
2119 and not null $ary->first->sibling->sibling)
2121 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
2122 $self->deparse($ary->first->sibling->sibling, 9);
2124 $ary = $self->deparse($ary, 1);
2127 if ($enter->flags & OPf_SPECIAL) { # thread special var
2128 $var = $self->pp_threadsv($enter, 1);
2129 } else { # regular my() variable
2130 $var = $self->pp_padsv($enter, 1);
2131 if ($self->padname_sv($enter->targ)->IVX ==
2132 $kid->first->first->sibling->last->cop_seq)
2134 # If the scope of this variable closes at the last
2135 # statement of the loop, it must have been
2137 $var = "my " . $var;
2140 } elsif ($var->name eq "rv2gv") {
2141 $var = $self->pp_rv2sv($var, 1);
2142 } elsif ($var->name eq "gv") {
2143 $var = "\$" . $self->deparse($var, 1);
2145 $head = "foreach $var ($ary) ";
2146 $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
2147 } elsif ($kid->name eq "null") { # while/until
2149 my $name = {"and" => "while", "or" => "until"}->{$kid->name};
2150 $cond = $self->deparse($kid->first, 1);
2151 $head = "$name ($cond) ";
2152 $body = $kid->first->sibling;
2153 } elsif ($kid->name eq "stub") { # bare and empty
2154 return "{;}"; # {} could be a hashref
2156 # If there isn't a continue block, then the next pointer for the loop
2157 # will point to the unstack, which is kid's penultimate child, except
2158 # in a bare loop, when it will point to the leaveloop. When neither of
2159 # these conditions hold, then the third-to-last child in the continue
2160 # block (or the last in a bare loop).
2161 my $cont_start = $enter->nextop;
2163 if ($$cont_start != $$op and $ {$cont_start->sibling} != $ {$body->last}) {
2165 $cont = $body->last;
2167 $cont = $body->first;
2168 while (!null($cont->sibling->sibling->sibling)) {
2169 $cont = $cont->sibling;
2172 my $state = $body->first;
2173 my $cuddle = $self->{'cuddle'};
2175 for (; $$state != $$cont; $state = $state->sibling) {
2176 push @states, $state;
2178 $body = $self->lineseq(@states);
2179 if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
2180 $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
2183 $cont = $cuddle . "continue {\n\t" .
2184 $self->deparse($cont, 0) . "\n\b}\cK";
2187 return "" if !defined $body;
2189 $body = $self->deparse($body, 0);
2192 # If we have say C<{my $x=2; sub x{$x}}>, the sub must go inside
2193 # the loop. So we insert any subs which are due here.
2194 $body .= join"", $self->seq_subs($out_seq);
2196 return $head . "{\n\t" . $body . "\b}" . $cont;
2199 sub pp_leaveloop { loop_common(@_, "") }
2204 my $init = $self->deparse($op, 1);
2205 return $self->loop_common($op->sibling, $cx, $init);
2210 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
2213 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
2214 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
2219 if (class($op) eq "OP") {
2221 return $self->{'ex_const'} if $op->targ == OP_CONST;
2222 } elsif ($op->first->name eq "pushmark") {
2223 return $self->pp_list($op, $cx);
2224 } elsif ($op->first->name eq "enter") {
2225 return $self->pp_leave($op, $cx);
2226 } elsif ($op->targ == OP_STRINGIFY) {
2227 return $self->dquote($op, $cx);
2228 } elsif (!null($op->first->sibling) and
2229 $op->first->sibling->name eq "readline" and
2230 $op->first->sibling->flags & OPf_STACKED) {
2231 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
2232 . $self->deparse($op->first->sibling, 7),
2234 } elsif (!null($op->first->sibling) and
2235 $op->first->sibling->name eq "trans" and
2236 $op->first->sibling->flags & OPf_STACKED) {
2237 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
2238 . $self->deparse($op->first->sibling, 20),
2241 return $self->deparse($op->first, $cx);
2248 return $self->padname_sv($targ)->PVX;
2254 return substr($self->padname($op->targ), 1); # skip $/@/%
2260 return $self->maybe_my($op, $cx, $self->padname($op->targ));
2263 sub pp_padav { pp_padsv(@_) }
2264 sub pp_padhv { pp_padsv(@_) }
2269 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
2270 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
2271 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
2278 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
2284 if (class($op) eq "PADOP") {
2285 return $self->padval($op->padix);
2286 } else { # class($op) eq "SVOP"
2294 my $gv = $self->gv_or_padgv($op);
2295 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($gv));
2301 my $gv = $self->gv_or_padgv($op);
2302 return $self->gv_name($gv);
2308 my $gv = $self->gv_or_padgv($op);
2309 return "\$" . $self->gv_name($gv) . "[" .
2310 ($op->private + $self->{'arybase'}) . "]";
2315 my($op, $cx, $type) = @_;
2316 my $kid = $op->first;
2317 my $str = $self->deparse($kid, 0);
2318 return $type . (is_scalar($kid) ? $str : "{$str}");
2321 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
2322 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
2323 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
2329 if ($op->first->name eq "padav") {
2330 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
2332 return $self->maybe_local($op, $cx,
2333 $self->rv2x($op->first, $cx, '$#'));
2337 # skip down to the old, ex-rv2cv
2338 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
2343 my $kid = $op->first;
2344 if ($kid->name eq "const") { # constant list
2345 my $av = $self->const_sv($kid);
2346 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
2348 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
2352 sub is_subscriptable {
2354 if ($op->name =~ /^[ahg]elem/) {
2356 } elsif ($op->name eq "entersub") {
2357 my $kid = $op->first;
2358 return 0 unless null $kid->sibling;
2360 $kid = $kid->sibling until null $kid->sibling;
2361 return 0 if is_scope($kid);
2363 return 0 if $kid->name eq "gv";
2364 return 0 if is_scalar($kid);
2365 return is_subscriptable($kid);
2373 my ($op, $cx, $left, $right, $padname) = @_;
2374 my($array, $idx) = ($op->first, $op->first->sibling);
2375 unless ($array->name eq $padname) { # Maybe this has been fixed
2376 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
2378 if ($array->name eq $padname) {
2379 $array = $self->padany($array);
2380 } elsif (is_scope($array)) { # ${expr}[0]
2381 $array = "{" . $self->deparse($array, 0) . "}";
2382 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
2383 $array = $self->deparse($array, 24);
2385 # $x[20][3]{hi} or expr->[20]
2386 my $arrow = is_subscriptable($array) ? "" : "->";
2387 return $self->deparse($array, 24) . $arrow .
2388 $left . $self->deparse($idx, 1) . $right;
2390 $idx = $self->deparse($idx, 1);
2392 # Outer parens in an array index will confuse perl
2393 # if we're interpolating in a regular expression, i.e.
2394 # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
2396 # If $self->{parens}, then an initial '(' will
2397 # definitely be paired with a final ')'. If
2398 # !$self->{parens}, the misleading parens won't
2399 # have been added in the first place.
2401 # [You might think that we could get "(...)...(...)"
2402 # where the initial and final parens do not match
2403 # each other. But we can't, because the above would
2404 # only happen if there's an infix binop between the
2405 # two pairs of parens, and *that* means that the whole
2406 # expression would be parenthesized as well.]
2408 $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
2410 return "\$" . $array . $left . $idx . $right;
2413 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
2414 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
2419 my($glob, $part) = ($op->first, $op->last);
2420 $glob = $glob->first; # skip rv2gv
2421 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
2422 my $scope = is_scope($glob);
2423 $glob = $self->deparse($glob, 0);
2424 $part = $self->deparse($part, 1);
2425 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
2430 my ($op, $cx, $left, $right, $regname, $padname) = @_;
2432 my(@elems, $kid, $array, $list);
2433 if (class($op) eq "LISTOP") {
2435 } else { # ex-hslice inside delete()
2436 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
2440 $array = $array->first
2441 if $array->name eq $regname or $array->name eq "null";
2442 if (is_scope($array)) {
2443 $array = "{" . $self->deparse($array, 0) . "}";
2444 } elsif ($array->name eq $padname) {
2445 $array = $self->padany($array);
2447 $array = $self->deparse($array, 24);
2449 $kid = $op->first->sibling; # skip pushmark
2450 if ($kid->name eq "list") {
2451 $kid = $kid->first->sibling; # skip list, pushmark
2452 for (; !null $kid; $kid = $kid->sibling) {
2453 push @elems, $self->deparse($kid, 6);
2455 $list = join(", ", @elems);
2457 $list = $self->deparse($kid, 1);
2459 return "\@" . $array . $left . $list . $right;
2462 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
2463 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
2468 my $idx = $op->first;
2469 my $list = $op->last;
2471 $list = $self->deparse($list, 1);
2472 $idx = $self->deparse($idx, 1);
2473 return "($list)" . "[$idx]";
2478 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2483 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2489 my $kid = $op->first->sibling; # skip pushmark
2490 my($meth, $obj, @exprs);
2491 if ($kid->name eq "list" and want_list $kid) {
2492 # When an indirect object isn't a bareword but the args are in
2493 # parens, the parens aren't part of the method syntax (the LLAFR
2494 # doesn't apply), but they make a list with OPf_PARENS set that
2495 # doesn't get flattened by the append_elem that adds the method,
2496 # making a (object, arg1, arg2, ...) list where the object
2497 # usually is. This can be distinguished from
2498 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2499 # object) because in the later the list is in scalar context
2500 # as the left side of -> always is, while in the former
2501 # the list is in list context as method arguments always are.
2502 # (Good thing there aren't method prototypes!)
2503 $meth = $kid->sibling;
2504 $kid = $kid->first->sibling; # skip pushmark
2506 $kid = $kid->sibling;
2507 for (; not null $kid; $kid = $kid->sibling) {
2508 push @exprs, $self->deparse($kid, 6);
2512 $kid = $kid->sibling;
2513 for (; not null $kid->sibling; $kid = $kid->sibling) {
2514 push @exprs, $self->deparse($kid, 6);
2518 $obj = $self->deparse($obj, 24);
2519 if ($meth->name eq "method_named") {
2520 $meth = $self->const_sv($meth)->PV;
2522 $meth = $meth->first;
2523 if ($meth->name eq "const") {
2524 # As of 5.005_58, this case is probably obsoleted by the
2525 # method_named case above
2526 $meth = $self->const_sv($meth)->PV; # needs to be bare
2528 $meth = $self->deparse($meth, 1);
2531 my $args = join(", ", @exprs);
2532 $kid = $obj . "->" . $meth;
2534 return $kid . "(" . $args . ")"; # parens mandatory
2540 # returns "&" if the prototype doesn't match the args,
2541 # or ("", $args_after_prototype_demunging) if it does.
2544 my($proto, @args) = @_;
2548 # An unbackslashed @ or % gobbles up the rest of the args
2549 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2551 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2554 return "&" if @args;
2555 } elsif ($chr eq ";") {
2557 } elsif ($chr eq "@" or $chr eq "%") {
2558 push @reals, map($self->deparse($_, 6), @args);
2564 if (want_scalar $arg) {
2565 push @reals, $self->deparse($arg, 6);
2569 } elsif ($chr eq "&") {
2570 if ($arg->name =~ /^(s?refgen|undef)$/) {
2571 push @reals, $self->deparse($arg, 6);
2575 } elsif ($chr eq "*") {
2576 if ($arg->name =~ /^s?refgen$/
2577 and $arg->first->first->name eq "rv2gv")
2579 $real = $arg->first->first; # skip refgen, null
2580 if ($real->first->name eq "gv") {
2581 push @reals, $self->deparse($real, 6);
2583 push @reals, $self->deparse($real->first, 6);
2588 } elsif (substr($chr, 0, 1) eq "\\") {
2589 $chr = substr($chr, 1);
2590 if ($arg->name =~ /^s?refgen$/ and
2591 !null($real = $arg->first) and
2592 ($chr eq "\$" && is_scalar($real->first)
2594 && $real->first->sibling->name
2597 && $real->first->sibling->name
2599 #or ($chr eq "&" # This doesn't work
2600 # && $real->first->name eq "rv2cv")
2602 && $real->first->name eq "rv2gv")))
2604 push @reals, $self->deparse($real, 6);
2611 return "&" if $proto and !$doneok; # too few args and no `;'
2612 return "&" if @args; # too many args
2613 return ("", join ", ", @reals);
2619 return $self->method($op, $cx) unless null $op->first->sibling;
2623 if ($op->flags & OPf_SPECIAL) {
2625 } elsif ($op->private & OPpENTERSUB_AMPER) {
2629 $kid = $kid->first->sibling; # skip ex-list, pushmark
2630 for (; not null $kid->sibling; $kid = $kid->sibling) {
2635 if (is_scope($kid)) {
2637 $kid = "{" . $self->deparse($kid, 0) . "}";
2638 } elsif ($kid->first->name eq "gv") {
2639 my $gv = $self->gv_or_padgv($kid->first);
2640 if (class($gv->CV) ne "SPECIAL") {
2641 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2643 $simple = 1; # only calls of named functions can be prototyped
2644 $kid = $self->deparse($kid, 24);
2645 } elsif (is_scalar $kid->first) {
2647 $kid = $self->deparse($kid, 24);
2650 my $arrow = is_subscriptable($kid->first) ? "" : "->";
2651 $kid = $self->deparse($kid, 24) . $arrow;
2654 # Doesn't matter how many prototypes there are, if
2655 # they haven't happened yet!
2656 my $declared = exists $self->{'subs_declared'}{$kid};
2659 if ($declared and defined $proto and not $amper) {
2660 ($amper, $args) = $self->check_proto($proto, @exprs);
2661 if ($amper eq "&") {
2662 $args = join(", ", map($self->deparse($_, 6), @exprs));
2665 $args = join(", ", map($self->deparse($_, 6), @exprs));
2667 if ($prefix or $amper) {
2668 if ($op->flags & OPf_STACKED) {
2669 return $prefix . $amper . $kid . "(" . $args . ")";
2671 return $prefix . $amper. $kid;
2674 # glob() invocations can be translated into calls of
2675 # CORE::GLOBAL::glob with an second parameter, a number.
2677 if ($kid eq "CORE::GLOBAL::glob") {
2679 $args =~ s/\s*,[^,]+$//;
2682 # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
2683 # so it must have been translated from a keyword call. Translate
2685 $kid =~ s/^CORE::GLOBAL:://;
2688 return "$kid(" . $args . ")";
2689 } elsif (defined $proto and $proto eq "") {
2691 } elsif (defined $proto and $proto eq "\$") {
2692 return $self->maybe_parens_func($kid, $args, $cx, 16);
2693 } elsif (defined($proto) && $proto or $simple) {
2694 return $self->maybe_parens_func($kid, $args, $cx, 5);
2696 return "$kid(" . $args . ")";
2701 sub pp_enterwrite { unop(@_, "write") }
2703 # escape things that cause interpolation in double quotes,
2704 # but not character escapes
2707 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2711 # the same, but treat $|, $), and $ at the end of the string differently
2714 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2715 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2719 # character escapes, but not delimiters that might need to be escaped
2720 sub escape_str { # ASCII, UTF8
2722 $str =~ s/(.)/ord($1)>255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
2724 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2730 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2731 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2735 # Don't do this for regexen
2738 $str =~ s/\\/\\\\/g;
2742 # Remove backslashes which precede literal control characters,
2743 # to avoid creating ambiguity when we escape the latter.
2747 # the insane complexity here is due to the behaviour of "\c\"
2748 $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[\0-\031\177-\377])/$1$2/g;
2752 sub balanced_delim {
2754 my @str = split //, $str;
2755 my($ar, $open, $close, $fail, $c, $cnt);
2756 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2757 ($open, $close) = @$ar;
2758 $fail = 0; $cnt = 0;
2762 } elsif ($c eq $close) {
2771 $fail = 1 if $cnt != 0;
2772 return ($open, "$open$str$close") if not $fail;
2778 my($q, $default, $str) = @_;
2779 return "$default$str$default" if $default and index($str, $default) == -1;
2780 my($succeed, $delim);
2781 ($succeed, $str) = balanced_delim($str);
2782 return "$q$str" if $succeed;
2783 for $delim ('/', '"', '#') {
2784 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2787 $str =~ s/$default/\\$default/g;
2788 return "$default$str$default";
2797 if (class($sv) eq "SPECIAL") {
2798 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2799 } elsif (class($sv) eq "NULL") {
2801 } elsif ($sv->FLAGS & SVf_IOK) {
2802 return $sv->int_value;
2803 } elsif ($sv->FLAGS & SVf_NOK) {
2805 } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
2806 return "\\(" . const($sv->RV) . ")"; # constant folded
2809 if ($str =~ /[^ -~]/) { # ASCII for non-printing
2810 return single_delim("qq", '"', uninterp escape_str unback $str);
2812 return single_delim("q", "'", unback $str);
2821 # the constant could be in the pad (under useithreads)
2822 $sv = $self->padval($op->targ) unless $$sv;
2829 if ($op->private & OPpCONST_ARYBASE) {
2832 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2833 # return $self->const_sv($op)->PV;
2835 my $sv = $self->const_sv($op);
2836 # return const($sv);
2838 return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
2844 my $type = $op->name;
2845 if ($type eq "const") {
2846 return '$[' if $op->private & OPpCONST_ARYBASE;
2847 return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
2848 } elsif ($type eq "concat") {
2849 my $first = $self->dq($op->first);
2850 my $last = $self->dq($op->last);
2851 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
2852 if ($last =~ /^[A-Z\\\^\[\]_?]/) {
2853 $first =~ s/([\$@])\^$/${1}{^}/; # "${^}W" etc
2855 elsif ($last =~ /^[{\[\w]/) {
2856 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
2858 return $first . $last;
2859 } elsif ($type eq "uc") {
2860 return '\U' . $self->dq($op->first->sibling) . '\E';
2861 } elsif ($type eq "lc") {
2862 return '\L' . $self->dq($op->first->sibling) . '\E';
2863 } elsif ($type eq "ucfirst") {
2864 return '\u' . $self->dq($op->first->sibling);
2865 } elsif ($type eq "lcfirst") {
2866 return '\l' . $self->dq($op->first->sibling);
2867 } elsif ($type eq "quotemeta") {
2868 return '\Q' . $self->dq($op->first->sibling) . '\E';
2869 } elsif ($type eq "join") {
2870 return $self->deparse($op->last, 26); # was join($", @ary)
2872 return $self->deparse($op, 26);
2880 return single_delim("qx", '`', $self->dq($op->first->sibling));
2886 my $kid = $op->first->sibling; # skip ex-stringify, pushmark
2887 return $self->deparse($kid, $cx) if $self->{'unquote'};
2888 $self->maybe_targmy($kid, $cx,
2889 sub {single_delim("qq", '"', $self->dq($_[1]))});
2892 # OP_STRINGIFY is a listop, but it only ever has one arg
2893 sub pp_stringify { maybe_targmy(@_, \&dquote) }
2895 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2896 # note that tr(from)/to/ is OK, but not tr/from/(to)
2898 my($from, $to) = @_;
2899 my($succeed, $delim);
2900 if ($from !~ m[/] and $to !~ m[/]) {
2901 return "/$from/$to/";
2902 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2903 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2906 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2907 return "$from$delim$to$delim" if index($to, $delim) == -1;
2910 return "$from/$to/";
2913 for $delim ('/', '"', '#') { # note no '
2914 return "$delim$from$delim$to$delim"
2915 if index($to . $from, $delim) == -1;
2917 $from =~ s[/][\\/]g;
2919 return "/$from/$to/";
2925 if ($n == ord '\\') {
2927 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2929 } elsif ($n == ord "\a") {
2931 } elsif ($n == ord "\b") {
2933 } elsif ($n == ord "\t") {
2935 } elsif ($n == ord "\n") {
2937 } elsif ($n == ord "\e") {
2939 } elsif ($n == ord "\f") {
2941 } elsif ($n == ord "\r") {
2943 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2944 return '\\c' . chr(ord("@") + $n);
2946 # return '\x' . sprintf("%02x", $n);
2947 return '\\' . sprintf("%03o", $n);
2953 my($str, $c, $tr) = ("");
2954 for ($c = 0; $c < @chars; $c++) {
2957 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2958 $chars[$c + 2] == $tr + 2)
2960 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2963 $str .= pchr($chars[$c]);
2969 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2972 sub tr_decode_byte {
2973 my($table, $flags) = @_;
2974 my(@table) = unpack("s256", $table);
2975 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2976 if ($table[ord "-"] != -1 and
2977 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2979 $tr = $table[ord "-"];
2980 $table[ord "-"] = -1;
2984 } else { # -2 ==> delete
2988 for ($c = 0; $c < 256; $c++) {
2991 push @from, $c; push @to, $tr;
2992 } elsif ($tr == -2) {
2996 @from = (@from, @delfrom);
2997 if ($flags & OPpTRANS_COMPLEMENT) {
3000 @from{@from} = (1) x @from;
3001 for ($c = 0; $c < 256; $c++) {
3002 push @newfrom, $c unless $from{$c};
3006 unless ($flags & OPpTRANS_DELETE || !@to) {
3007 pop @to while $#to and $to[$#to] == $to[$#to -1];
3010 $from = collapse(@from);
3011 $to = collapse(@to);
3012 $from .= "-" if $delhyphen;
3013 return ($from, $to);
3018 if ($x == ord "-") {
3025 # XXX This doesn't yet handle all cases correctly either
3027 sub tr_decode_utf8 {
3028 my($swash_hv, $flags) = @_;
3029 my %swash = $swash_hv->ARRAY;
3031 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
3032 my $none = $swash{"NONE"}->IV;
3033 my $extra = $none + 1;
3034 my(@from, @delfrom, @to);
3036 foreach $line (split /\n/, $swash{'LIST'}->PV) {
3037 my($min, $max, $result) = split(/\t/, $line);
3044 $result = hex $result;
3045 if ($result == $extra) {
3046 push @delfrom, [$min, $max];
3048 push @from, [$min, $max];
3049 push @to, [$result, $result + $max - $min];
3052 for my $i (0 .. $#from) {
3053 if ($from[$i][0] == ord '-') {
3054 unshift @from, splice(@from, $i, 1);
3055 unshift @to, splice(@to, $i, 1);
3057 } elsif ($from[$i][1] == ord '-') {
3060 unshift @from, ord '-';
3061 unshift @to, ord '-';
3065 for my $i (0 .. $#delfrom) {
3066 if ($delfrom[$i][0] == ord '-') {
3067 push @delfrom, splice(@delfrom, $i, 1);
3069 } elsif ($delfrom[$i][1] == ord '-') {
3071 push @delfrom, ord '-';
3075 if (defined $final and $to[$#to][1] != $final) {
3076 push @to, [$final, $final];
3078 push @from, @delfrom;
3079 if ($flags & OPpTRANS_COMPLEMENT) {
3082 for my $i (0 .. $#from) {
3083 push @newfrom, [$next, $from[$i][0] - 1];
3084 $next = $from[$i][1] + 1;
3087 for my $range (@newfrom) {
3088 if ($range->[0] <= $range->[1]) {
3093 my($from, $to, $diff);
3094 for my $chunk (@from) {
3095 $diff = $chunk->[1] - $chunk->[0];
3097 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3098 } elsif ($diff == 1) {
3099 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3101 $from .= tr_chr($chunk->[0]);
3104 for my $chunk (@to) {
3105 $diff = $chunk->[1] - $chunk->[0];
3107 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
3108 } elsif ($diff == 1) {
3109 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
3111 $to .= tr_chr($chunk->[0]);
3114 #$final = sprintf("%04x", $final) if defined $final;
3115 #$none = sprintf("%04x", $none) if defined $none;
3116 #$extra = sprintf("%04x", $extra) if defined $extra;
3117 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
3118 #print STDERR $swash{'LIST'}->PV;
3119 return (escape_str($from), escape_str($to));
3126 if (class($op) eq "PVOP") {
3127 ($from, $to) = tr_decode_byte($op->pv, $op->private);
3128 } else { # class($op) eq "SVOP"
3129 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
3132 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
3133 $flags .= "d" if $op->private & OPpTRANS_DELETE;
3134 $to = "" if $from eq $to and $flags eq "";
3135 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
3136 return "tr" . double_delim($from, $to) . $flags;
3139 # Like dq(), but different
3143 my $type = $op->name;
3144 if ($type eq "const") {
3145 return '$[' if $op->private & OPpCONST_ARYBASE;
3146 return re_uninterp(escape_str(re_unback($self->const_sv($op)->as_string)));
3147 } elsif ($type eq "concat") {
3148 my $first = $self->re_dq($op->first);
3149 my $last = $self->re_dq($op->last);
3150 # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
3151 if ($last =~ /^[A-Z\\\^\[\]_?]/) {
3152 $first =~ s/([\$@])\^$/${1}{^}/;
3154 elsif ($last =~ /^[{\[\w]/) {
3155 $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/;
3157 return $first . $last;
3158 } elsif ($type eq "uc") {
3159 return '\U' . $self->re_dq($op->first->sibling) . '\E';
3160 } elsif ($type eq "lc") {
3161 return '\L' . $self->re_dq($op->first->sibling) . '\E';
3162 } elsif ($type eq "ucfirst") {
3163 return '\u' . $self->re_dq($op->first->sibling);
3164 } elsif ($type eq "lcfirst") {
3165 return '\l' . $self->re_dq($op->first->sibling);
3166 } elsif ($type eq "quotemeta") {
3167 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
3168 } elsif ($type eq "join") {
3169 return $self->deparse($op->last, 26); # was join($", @ary)
3171 return $self->deparse($op, 26);
3178 my $kid = $op->first;
3179 $kid = $kid->first if $kid->name eq "regcmaybe";
3180 $kid = $kid->first if $kid->name eq "regcreset";
3181 return $self->re_dq($kid);
3184 # osmic acid -- see osmium tetroxide
3187 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
3188 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
3189 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
3193 my($op, $cx, $name, $delim) = @_;
3194 my $kid = $op->first;
3195 my ($binop, $var, $re) = ("", "", "");
3196 if ($op->flags & OPf_STACKED) {
3198 $var = $self->deparse($kid, 20);
3199 $kid = $kid->sibling;
3202 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3204 $re = $self->deparse($kid, 1);
3207 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
3208 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3209 $flags .= "i" if $op->pmflags & PMf_FOLD;
3210 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3211 $flags .= "o" if $op->pmflags & PMf_KEEP;
3212 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3213 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3214 $flags = $matchwords{$flags} if $matchwords{$flags};
3215 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
3219 $re = single_delim($name, $delim, $re);
3223 return $self->maybe_parens("$var =~ $re", $cx, 20);
3229 sub pp_match { matchop(@_, "m", "/") }
3230 sub pp_pushre { matchop(@_, "m", "/") }
3231 sub pp_qr { matchop(@_, "qr", "") }
3236 my($kid, @exprs, $ary, $expr);
3238 if ($ {$kid->pmreplroot}) {
3239 $ary = '@' . $self->gv_name($kid->pmreplroot);
3241 for (; !null($kid); $kid = $kid->sibling) {
3242 push @exprs, $self->deparse($kid, 6);
3245 # handle special case of split(), and split(" ") that compiles to /\s+/
3247 if ($kid->flags & OPf_SPECIAL
3248 && $exprs[0] eq '/\\s+/'
3249 && $kid->pmflags & PMf_SKIPWHITE ) {
3253 $expr = "split(" . join(", ", @exprs) . ")";
3255 return $self->maybe_parens("$ary = $expr", $cx, 7);
3261 # oxime -- any of various compounds obtained chiefly by the action of
3262 # hydroxylamine on aldehydes and ketones and characterized by the
3263 # bivalent grouping C=NOH [Webster's Tenth]
3266 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
3267 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
3268 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
3269 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
3274 my $kid = $op->first;
3275 my($binop, $var, $re, $repl) = ("", "", "", "");
3276 if ($op->flags & OPf_STACKED) {
3278 $var = $self->deparse($kid, 20);
3279 $kid = $kid->sibling;
3282 if (null($op->pmreplroot)) {
3283 $repl = $self->dq($kid);
3284 $kid = $kid->sibling;
3286 $repl = $op->pmreplroot->first; # skip substcont
3287 while ($repl->name eq "entereval") {
3288 $repl = $repl->first;
3291 if ($op->pmflags & PMf_EVAL) {
3292 $repl = $self->deparse($repl, 0);
3294 $repl = $self->dq($repl);
3298 $re = re_uninterp(escape_str(re_unback($op->precomp)));
3300 $re = $self->deparse($kid, 1);
3302 $flags .= "e" if $op->pmflags & PMf_EVAL;
3303 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
3304 $flags .= "i" if $op->pmflags & PMf_FOLD;
3305 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
3306 $flags .= "o" if $op->pmflags & PMf_KEEP;
3307 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
3308 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
3309 $flags = $substwords{$flags} if $substwords{$flags};
3311 return $self->maybe_parens("$var =~ s"
3312 . double_delim($re, $repl) . $flags,
3315 return "s". double_delim($re, $repl) . $flags;
3324 B::Deparse - Perl compiler backend to produce perl code
3328 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>]
3329 [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
3333 B::Deparse is a backend module for the Perl compiler that generates
3334 perl source code, based on the internal compiled structure that perl
3335 itself creates after parsing a program. The output of B::Deparse won't
3336 be exactly the same as the original source, since perl doesn't keep
3337 track of comments or whitespace, and there isn't a one-to-one
3338 correspondence between perl's syntactical constructions and their
3339 compiled form, but it will often be close. When you use the B<-p>
3340 option, the output also includes parentheses even when they are not
3341 required by precedence, which can make it easy to see if perl is
3342 parsing your expressions the way you intended.
3344 Please note that this module is mainly new and untested code and is
3345 still under development, so it may change in the future.
3349 As with all compiler backend options, these must follow directly after
3350 the '-MO=Deparse', separated by a comma but not any white space.
3356 Add '#line' declarations to the output based on the line and file
3357 locations of the original code.
3361 Print extra parentheses. Without this option, B::Deparse includes
3362 parentheses in its output only when they are needed, based on the
3363 structure of your program. With B<-p>, it uses parentheses (almost)
3364 whenever they would be legal. This can be useful if you are used to
3365 LISP, or if you want to see how perl parses your input. If you say
3367 if ($var & 0x7f == 65) {print "Gimme an A!"}
3368 print ($which ? $a : $b), "\n";
3369 $name = $ENV{USER} or "Bob";
3371 C<B::Deparse,-p> will print
3374 print('Gimme an A!')
3376 (print(($which ? $a : $b)), '???');
3377 (($name = $ENV{'USER'}) or '???')
3379 which probably isn't what you intended (the C<'???'> is a sign that
3380 perl optimized away a constant value).
3384 Expand double-quoted strings into the corresponding combinations of
3385 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
3388 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
3392 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
3393 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
3395 Note that the expanded form represents the way perl handles such
3396 constructions internally -- this option actually turns off the reverse
3397 translation that B::Deparse usually does. On the other hand, note that
3398 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
3399 of $y into a string before doing the assignment.
3403 Normally, B::Deparse deparses the main code of a program, and all the subs
3404 defined in the same file. To include subs defined in other files, pass the
3405 B<-f> option with the filename. You can pass the B<-f> option several times, to
3406 include more than one secondary file. (Most of the time you don't want to
3407 use it at all.) You can also use this option to include subs which are
3408 defined in the scope of a B<#line> directive with two parameters.
3410 =item B<-s>I<LETTERS>
3412 Tweak the style of B::Deparse's output. The letters should follow
3413 directly after the 's', with no space or punctuation. The following
3414 options are available:
3420 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
3437 The default is not to cuddle.
3441 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
3445 Use tabs for each 8 columns of indent. The default is to use only spaces.
3446 For instance, if the style options are B<-si4T>, a line that's indented
3447 3 times will be preceded by one tab and four spaces; if the options were
3448 B<-si8T>, the same line would be preceded by three tabs.
3450 =item B<v>I<STRING>B<.>
3452 Print I<STRING> for the value of a constant that can't be determined
3453 because it was optimized away (mnemonic: this happens when a constant
3454 is used in B<v>oid context). The end of the string is marked by a period.
3455 The string should be a valid perl expression, generally a constant.
3456 Note that unless it's a number, it probably needs to be quoted, and on
3457 a command line quotes need to be protected from the shell. Some
3458 conventional values include 0, 1, 42, '', 'foo', and
3459 'Useless use of constant omitted' (which may need to be
3460 B<-sv"'Useless use of constant omitted'.">
3461 or something similar depending on your shell). The default is '???'.
3462 If you're using B::Deparse on a module or other file that's require'd,
3463 you shouldn't use a value that evaluates to false, since the customary
3464 true constant at the end of a module will be in void context when the
3465 file is compiled as a main program.
3471 Expand conventional syntax constructions into equivalent ones that expose
3472 their internal operation. I<LEVEL> should be a digit, with higher values
3473 meaning more expansion. As with B<-q>, this actually involves turning off
3474 special cases in B::Deparse's normal operations.
3476 If I<LEVEL> is at least 3, for loops will be translated into equivalent
3477 while loops with continue blocks; for instance
3479 for ($i = 0; $i < 10; ++$i) {
3492 Note that in a few cases this translation can't be perfectly carried back
3493 into the source code -- if the loop's initializer declares a my variable,
3494 for instance, it won't have the correct scope outside of the loop.
3496 If I<LEVEL> is at least 7, if statements will be translated into equivalent
3497 expressions using C<&&>, C<?:> and C<do {}>; for instance
3499 print 'hi' if $nice;
3511 $nice and print 'hi';
3512 $nice and do { print 'hi' };
3513 $nice ? do { print 'hi' } : do { print 'bye' };
3515 Long sequences of elsifs will turn into nested ternary operators, which
3516 B::Deparse doesn't know how to indent nicely.
3520 =head1 USING B::Deparse AS A MODULE
3525 $deparse = B::Deparse->new("-p", "-sC");
3526 $body = $deparse->coderef2text(\&func);
3527 eval "sub func $body"; # the inverse operation
3531 B::Deparse can also be used on a sub-by-sub basis from other perl
3536 $deparse = B::Deparse->new(OPTIONS)
3538 Create an object to store the state of a deparsing operation and any
3539 options. The options are the same as those that can be given on the
3540 command line (see L</OPTIONS>); options that are separated by commas
3541 after B<-MO=Deparse> should be given as separate strings. Some
3542 options, like B<-u>, don't make sense for a single subroutine, so
3545 =head2 ambient_pragmas
3547 $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
3549 The compilation of a subroutine can be affected by a few compiler
3550 directives, B<pragmas>. These are:
3564 Assigning to the special variable $[
3584 Ordinarily, if you use B::Deparse on a subroutine which has
3585 been compiled in the presence of one or more of these pragmas,
3586 the output will include statements to turn on the appropriate
3587 directives. So if you then compile the code returned by coderef2text,
3588 it will behave the same way as the subroutine which you deparsed.
3590 However, you may know that you intend to use the results in a
3591 particular context, where some pragmas are already in scope. In
3592 this case, you use the B<ambient_pragmas> method to describe the
3593 assumptions you wish to make.
3595 The parameters it accepts are:
3601 Takes a string, possibly containing several values separated
3602 by whitespace. The special values "all" and "none" mean what you'd
3605 $deparse->ambient_pragmas(strict => 'subs refs');
3609 Takes a number, the value of the array base $[.
3617 If the value is true, then the appropriate pragma is assumed to
3618 be in the ambient scope, otherwise not.
3622 Takes a string, possibly containing a whitespace-separated list of
3623 values. The values "all" and "none" are special. It's also permissible
3624 to pass an array reference here.
3626 $deparser->ambient_pragmas(re => 'eval');
3631 Takes a string, possibly containing a whitespace-separated list of
3632 values. The values "all" and "none" are special, again. It's also
3633 permissible to pass an array reference here.
3635 $deparser->ambient_pragmas(warnings => [qw[void io]]);
3637 If one of the values is the string "FATAL", then all the warnings
3638 in that list will be considered fatal, just as with the B<warnings>
3639 pragma itself. Should you need to specify that some warnings are
3640 fatal, and others are merely enabled, you can pass the B<warnings>
3643 $deparser->ambient_pragmas(
3645 warnings => [FATAL => qw/void io/],
3648 See L<perllexwarn> for more information about lexical warnings.
3654 These two parameters are used to specify the ambient pragmas in
3655 the format used by the special variables $^H and ${^WARNING_BITS}.
3657 They exist principally so that you can write code like:
3659 { my ($hint_bits, $warning_bits);
3660 BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
3661 $deparser->ambient_pragmas (
3662 hint_bits => $hint_bits,
3663 warning_bits => $warning_bits,
3667 which specifies that the ambient pragmas are exactly those which
3668 are in scope at the point of calling.
3674 $body = $deparse->coderef2text(\&func)
3675 $body = $deparse->coderef2text(sub ($$) { ... })
3677 Return source code for the body of a subroutine (a block, optionally
3678 preceded by a prototype in parens), given a reference to the
3679 sub. Because a subroutine can have no names, or more than one name,
3680 this method doesn't return a complete subroutine definition -- if you
3681 want to eval the result, you should prepend "sub subname ", or "sub "
3682 for an anonymous function constructor. Unless the sub was defined in
3683 the main:: package, the code will include a package declaration.
3687 See the 'to do' list at the beginning of the module file.
3691 Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier
3692 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
3693 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
3694 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.