2 # Copyright (c) 1998,1999 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
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
16 SVf_IOK SVf_NOK SVf_ROK SVf_POK
17 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
18 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
22 # Changes between 0.50 and 0.51:
23 # - fixed nulled leave with live enter in sort { }
24 # - fixed reference constants (\"str")
25 # - handle empty programs gracefully
26 # - handle infinte loops (for (;;) {}, while (1) {})
27 # - differentiate between `for my $x ...' and `my $x; for $x ...'
28 # - various minor cleanups
29 # - moved globals into an object
30 # - added `-u', like B::C
31 # - package declarations using cop_stash
32 # - subs, formats and code sorted by cop_seq
33 # Changes between 0.51 and 0.52:
34 # - added pp_threadsv (special variables under USE_THREADS)
35 # - added documentation
36 # Changes between 0.52 and 0.53:
37 # - many changes adding precedence contexts and associativity
38 # - added `-p' and `-s' output style options
39 # - various other minor fixes
40 # Changes between 0.53 and 0.54:
41 # - added support for new `for (1..100)' optimization,
43 # Changes between 0.54 and 0.55:
44 # - added support for new qr// construct
45 # - added support for new pp_regcreset OP
46 # Changes between 0.55 and 0.56:
47 # - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
48 # - fixed $# on non-lexicals broken in last big rewrite
49 # - added temporary fix for change in opcode of OP_STRINGIFY
50 # - fixed problem in 0.54's for() patch in `for (@ary)'
51 # - fixed precedence in conditional of ?:
52 # - tweaked list paren elimination in `my($x) = @_'
53 # - made continue-block detection trickier wrt. null ops
54 # - fixed various prototype problems in pp_entersub
55 # - added support for sub prototypes that never get GVs
56 # - added unquoting for special filehandle first arg in truncate
57 # - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
58 # - added semicolons at the ends of blocks
59 # - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
60 # Changes between 0.56 and 0.561:
61 # - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
62 # - used new B.pm symbolic constants (done by Nick Ing-Simmons)
63 # Changes between 0.561 and 0.57:
64 # - stylistic changes to symbolic constant stuff
65 # - handled scope in s///e replacement code
66 # - added unquote option for expanding "" into concats, etc.
67 # - split method and proto parts of pp_entersub into separate functions
68 # - various minor cleanups
70 # - added parens in \&foo (patch by Albert Dvornik)
71 # Changes between 0.57 and 0.58:
72 # - fixed `0' statements that weren't being printed
73 # - added methods for use from other programs
74 # (based on patches from James Duncan and Hugo van der Sanden)
75 # - added -si and -sT to control indenting (also based on a patch from Hugo)
76 # - added -sv to print something else instead of '???'
77 # - preliminary version of utf8 tr/// handling
80 # - finish tr/// changes
81 # - add option for even more parens (generalize \&foo change)
82 # - {} around variables in strings ("${var}letters")
85 # - left/right context
86 # - recognize `use utf8', `use integer', etc
87 # - treat top-level block specially for incremental output
88 # - interpret in high bit chars in string as utf8 \x{...} (when?)
89 # - copy comments (look at real text with $^P)
90 # - avoid semis in one-statement blocks
91 # - associativity of &&=, ||=, ?:
92 # - ',' => '=>' (auto-unquote?)
93 # - break long lines ("\r" as discretionary break?)
94 # - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
95 # - more style options: brace style, hex vs. octal, quotes, ...
96 # - print big ints as hex/octal instead of decimal (heuristic?)
97 # - include values of variables (e.g. set in BEGIN)
98 # - coordinate with Data::Dumper (both directions? see previous)
99 # - version using op_next instead of op_first/sibling?
100 # - avoid string copies (pass arrays, one big join?)
102 # - while{} with one-statement continue => for(; XXX; XXX) {}?
103 # - -uPackage:: descend recursively?
107 # Tests that will always fail:
108 # comp/redef.t -- all (redefinition happens at compile time)
110 # Object fields (were globals):
113 # (local($a), local($b)) and local($a, $b) have the same internal
114 # representation but the short form looks better. We notice we can
115 # use a large-scale local when checking the list, but need to prevent
116 # individual locals too. This hash holds the addresses of OPs that
117 # have already had their local-ness accounted for. The same thing
121 # CV for current sub (or main program) being deparsed
124 # name of the current package for deparsed code
127 # array of [cop_seq, GV, is_format?] for subs and formats we still
131 # as above, but [name, prototype] for subs that never got a GV
133 # subs_done, forms_done:
134 # keys are addresses of GVs for subs and formats we've already
135 # deparsed (or at least put into subs_todo)
140 # cuddle: ` ' or `\n', depending on -sC
145 # A little explanation of how precedence contexts and associativity
148 # deparse() calls each per-op subroutine with an argument $cx (short
149 # for context, but not the same as the cx* in the perl core), which is
150 # a number describing the op's parents in terms of precedence, whether
151 # they're inside an expression or at statement level, etc. (see
152 # chart below). When ops with children call deparse on them, they pass
153 # along their precedence. Fractional values are used to implement
154 # associativity (`($x + $y) + $z' => `$x + $y + $y') and related
155 # parentheses hacks. The major disadvantage of this scheme is that
156 # it doesn't know about right sides and left sides, so say if you
157 # assign a listop to a variable, it can't tell it's allowed to leave
158 # the parens off the listop.
161 # 26 [TODO] inside interpolation context ("")
162 # 25 left terms and list operators (leftward)
166 # 21 right ! ~ \ and unary + and -
171 # 16 nonassoc named unary operators
172 # 15 nonassoc < > <= >= lt gt le ge
173 # 14 nonassoc == != <=> eq ne cmp
180 # 7 right = += -= *= etc.
182 # 5 nonassoc list operators (rightward)
186 # 1 statement modifiers
189 # Nonprinting characters with special meaning:
190 # \cS - steal parens (see maybe_parens_unop)
191 # \n - newline and indent
192 # \t - increase indent
193 # \b - decrease indent (`outdent')
194 # \f - flush left (no indent)
195 # \cK - kill following semicolon, if any
199 return class($op) eq "NULL";
204 my($gv, $cv, $is_form) = @_;
206 if (!null($cv->START) and is_state($cv->START)) {
207 $seq = $cv->START->cop_seq;
211 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
216 my $ent = shift @{$self->{'subs_todo'}};
217 my $name = $self->gv_name($ent->[1]);
219 return "format $name =\n"
220 . $self->deparse_format($ent->[1]->FORM). "\n";
222 return "sub $name " .
223 $self->deparse_sub($ent->[1]->CV);
230 if ($op->flags & OPf_KIDS) {
232 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
233 walk_tree($kid, $sub);
242 $op = shift if null $op;
243 return if !$op or null $op;
246 if ($op->name eq "gv") {
247 if ($op->next->name eq "entersub") {
248 next if $self->{'subs_done'}{$ {$op->gv}}++;
249 next if class($op->gv->CV) eq "SPECIAL";
250 $self->todo($op->gv, $op->gv->CV, 0);
251 $self->walk_sub($op->gv->CV);
252 } elsif ($op->next->name eq "enterwrite"
253 or ($op->next->name eq "rv2gv"
254 and $op->next->next->name eq "enterwrite")) {
255 next if $self->{'forms_done'}{$ {$op->gv}}++;
256 next if class($op->gv->FORM) eq "SPECIAL";
257 $self->todo($op->gv, $op->gv->FORM, 1);
258 $self->walk_sub($op->gv->FORM);
268 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
269 if ($pack eq "main") {
272 $pack = $pack . "::";
275 while (($key, $val) = each %stash) {
276 my $class = class($val);
277 if ($class eq "PV") {
279 push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
280 } elsif ($class eq "IV") {
282 push @{$self->{'protos_todo'}}, [$pack . $key, undef];
283 } elsif ($class eq "GV") {
284 if (class($val->CV) ne "SPECIAL") {
285 next if $self->{'subs_done'}{$$val}++;
286 $self->todo($val, $val->CV, 0);
287 $self->walk_sub($val->CV);
289 if (class($val->FORM) ne "SPECIAL") {
290 next if $self->{'forms_done'}{$$val}++;
291 $self->todo($val, $val->FORM, 1);
292 $self->walk_sub($val->FORM);
302 foreach $ar (@{$self->{'protos_todo'}}) {
303 my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
304 push @ret, "sub " . $ar->[0] . "$proto;\n";
306 delete $self->{'protos_todo'};
314 while (length($opt = substr($opts, 0, 1))) {
316 $self->{'cuddle'} = " ";
317 $opts = substr($opts, 1);
318 } elsif ($opt eq "i") {
319 $opts =~ s/^i(\d+)//;
320 $self->{'indent_size'} = $1;
321 } elsif ($opt eq "T") {
322 $self->{'use_tabs'} = 1;
323 $opts = substr($opts, 1);
324 } elsif ($opt eq "v") {
325 $opts =~ s/^v([^.]*)(.|$)//;
326 $self->{'ex_const'} = $1;
333 my $self = bless {}, $class;
334 $self->{'subs_todo'} = [];
335 $self->{'curstash'} = "main";
336 $self->{'cuddle'} = "\n";
337 $self->{'indent_size'} = 4;
338 $self->{'use_tabs'} = 0;
339 $self->{'ex_const'} = "'???'";
340 while (my $arg = shift @_) {
341 if (substr($arg, 0, 2) eq "-u") {
342 $self->stash_subs(substr($arg, 2));
343 } elsif ($arg eq "-p") {
344 $self->{'parens'} = 1;
345 } elsif ($arg eq "-l") {
346 $self->{'linenums'} = 1;
347 } elsif ($arg eq "-q") {
348 $self->{'unquote'} = 1;
349 } elsif (substr($arg, 0, 2) eq "-s") {
350 $self->style_opts(substr $arg, 2);
359 my $self = B::Deparse->new(@args);
360 $self->stash_subs("main");
361 $self->{'curcv'} = main_cv;
362 $self->walk_sub(main_cv, main_start);
363 print $self->print_protos;
364 @{$self->{'subs_todo'}} =
365 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
366 print $self->indent($self->deparse(main_root, 0)), "\n"
367 unless null main_root;
369 while (scalar(@{$self->{'subs_todo'}})) {
370 push @text, $self->next_todo;
372 print indent(join("", @text)), "\n" if @text;
379 croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
380 return $self->indent($self->deparse_sub(svref_2object($sub)));
386 # cluck if class($op) eq "NULL";
387 # return $self->$ {\("pp_" . $op->name)}($op, $cx);
388 my $meth = "pp_" . $op->name;
389 return $self->$meth($op, $cx);
395 my @lines = split(/\n/, $txt);
400 my $cmd = substr($line, 0, 1);
401 if ($cmd eq "\t" or $cmd eq "\b") {
402 $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
403 if ($self->{'use_tabs'}) {
404 $leader = "\t" x ($level / 8) . " " x ($level % 8);
406 $leader = " " x $level;
408 $line = substr($line, 1);
410 if (substr($line, 0, 1) eq "\f") {
411 $line = substr($line, 1); # no indent
413 $line = $leader . $line;
417 return join("\n", @lines);
424 if ($cv->FLAGS & SVf_POK) {
425 $proto = "(". $cv->PV . ") ";
427 local($self->{'curcv'}) = $cv;
428 local($self->{'curstash'}) = $self->{'curstash'};
429 if (not null $cv->ROOT) {
431 return $proto . "{\n\t" .
432 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
434 return $proto . "{}\n";
442 local($self->{'curcv'}) = $form;
443 local($self->{'curstash'}) = $self->{'curstash'};
444 my $op = $form->ROOT;
446 $op = $op->first->first; # skip leavewrite, lineseq
447 while (not null $op) {
448 $op = $op->sibling; # skip nextstate
450 $kid = $op->first->sibling; # skip pushmark
451 push @text, $kid->sv->PV;
452 $kid = $kid->sibling;
453 for (; not null $kid; $kid = $kid->sibling) {
454 push @exprs, $self->deparse($kid, 0);
456 push @text, join(", ", @exprs)."\n" if @exprs;
459 return join("", @text) . ".";
464 return $op->name eq "leave" || $op->name eq "scope"
465 || $op->name eq "lineseq"
466 || ($op->name eq "null" && class($op) eq "UNOP"
467 && (is_scope($op->first) || $op->first->name eq "enter"));
471 my $name = $_[0]->name;
472 return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
475 sub is_miniwhile { # check for one-line loop (`foo() while $y--')
477 return (!null($op) and null($op->sibling)
478 and $op->name eq "null" and class($op) eq "UNOP"
479 and (($op->first->name =~ /^(and|or)$/
480 and $op->first->first->sibling->name eq "lineseq")
481 or ($op->first->name eq "lineseq"
482 and not null $op->first->first->sibling
483 and $op->first->first->sibling->name eq "unstack")
489 return ($op->name eq "rv2sv" or
490 $op->name eq "padsv" or
491 $op->name eq "gv" or # only in array/hash constructs
492 $op->flags & OPf_KIDS && !null($op->first)
493 && $op->first->name eq "gvsv");
498 my($text, $cx, $prec) = @_;
499 if ($prec < $cx # unary ops nest just fine
500 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
501 or $self->{'parens'})
504 # In a unop, let parent reuse our parens; see maybe_parens_unop
505 $text = "\cS" . $text if $cx == 16;
512 # same as above, but get around the `if it looks like a function' rule
513 sub maybe_parens_unop {
515 my($name, $kid, $cx) = @_;
516 if ($cx > 16 or $self->{'parens'}) {
517 return "$name(" . $self->deparse($kid, 1) . ")";
519 $kid = $self->deparse($kid, 16);
520 if (substr($kid, 0, 1) eq "\cS") {
522 return $name . substr($kid, 1);
523 } elsif (substr($kid, 0, 1) eq "(") {
524 # avoid looks-like-a-function trap with extra parens
525 # (`+' can lead to ambiguities)
526 return "$name(" . $kid . ")";
533 sub maybe_parens_func {
535 my($func, $text, $cx, $prec) = @_;
536 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
537 return "$func($text)";
539 return "$func $text";
545 my($op, $cx, $text) = @_;
546 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
547 return $self->maybe_parens_func("local", $text, $cx, 16);
556 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
561 my($op, $cx, $text) = @_;
562 if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
563 return $self->maybe_parens_func("my", $text, $cx, 16);
569 # The following OPs don't have functions:
571 # pp_padany -- does not exist after parsing
572 # pp_rcatline -- does not exist
574 sub pp_enter { # see also leave
575 cluck "unexpected OP_ENTER";
579 sub pp_pushmark { # see also list
580 cluck "unexpected OP_PUSHMARK";
584 sub pp_leavesub { # see also deparse_sub
585 cluck "unexpected OP_LEAVESUB";
589 sub pp_leavewrite { # see also deparse_format
590 cluck "unexpected OP_LEAVEWRITE";
594 sub pp_method { # see also entersub
595 cluck "unexpected OP_METHOD";
599 sub pp_regcmaybe { # see also regcomp
600 cluck "unexpected OP_REGCMAYBE";
604 sub pp_regcreset { # see also regcomp
605 cluck "unexpected OP_REGCRESET";
609 sub pp_substcont { # see also subst
610 cluck "unexpected OP_SUBSTCONT";
614 sub pp_grepstart { # see also grepwhile
615 cluck "unexpected OP_GREPSTART";
619 sub pp_mapstart { # see also mapwhile
620 cluck "unexpected OP_MAPSTART";
624 sub pp_flip { # see also flop
625 cluck "unexpected OP_FLIP";
629 sub pp_iter { # see also leaveloop
630 cluck "unexpected OP_ITER";
634 sub pp_enteriter { # see also leaveloop
635 cluck "unexpected OP_ENTERITER";
639 sub pp_enterloop { # see also leaveloop
640 cluck "unexpected OP_ENTERLOOP";
644 sub pp_leaveeval { # see also entereval
645 cluck "unexpected OP_LEAVEEVAL";
649 sub pp_entertry { # see also leavetry
650 cluck "unexpected OP_ENTERTRY";
654 # leave and scope/lineseq should probably share code
660 local($self->{'curstash'}) = $self->{'curstash'};
661 $kid = $op->first->sibling; # skip enter
662 if (is_miniwhile($kid)) {
663 my $top = $kid->first;
664 my $name = $top->name;
665 if ($name eq "and") {
667 } elsif ($name eq "or") {
669 } else { # no conditional -> while 1 or until 0
670 return $self->deparse($top->first, 1) . " while 1";
672 my $cond = $top->first;
673 my $body = $cond->sibling->first; # skip lineseq
674 $cond = $self->deparse($cond, 1);
675 $body = $self->deparse($body, 1);
676 return "$body $name $cond";
678 for (; !null($kid); $kid = $kid->sibling) {
681 $expr = $self->deparse($kid, 0);
682 $kid = $kid->sibling;
685 $expr .= $self->deparse($kid, 0);
686 push @exprs, $expr if length $expr;
688 if ($cx > 0) { # inside an expression
689 return "do { " . join(";\n", @exprs) . " }";
691 return join(";\n", @exprs) . ";";
700 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
703 $expr = $self->deparse($kid, 0);
704 $kid = $kid->sibling;
707 $expr .= $self->deparse($kid, 0);
708 push @exprs, $expr if length $expr;
710 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
711 return "do { " . join(";\n", @exprs) . " }";
713 return join(";\n", @exprs) . ";";
717 sub pp_lineseq { pp_scope(@_) }
719 # The BEGIN {} is used here because otherwise this code isn't executed
720 # when you run B::Deparse on itself.
722 BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
723 "ENV", "ARGV", "ARGVOUT", "_"); }
728 my $stash = $gv->STASH->NAME;
729 my $name = $gv->NAME;
730 if ($stash eq $self->{'curstash'} or $globalnames{$name}
731 or $name =~ /^[^A-Za-z_]/)
735 $stash = $stash . "::";
737 if ($name =~ /^([\cA-\cZ])$/) {
738 $name = "^" . chr(64 + ord($1));
740 return $stash . $name;
743 # Notice how subs and formats are inserted between statements here
748 @text = $op->label . ": " if $op->label;
749 my $seq = $op->cop_seq;
750 while (scalar(@{$self->{'subs_todo'}})
751 and $seq > $self->{'subs_todo'}[0][0]) {
752 push @text, $self->next_todo;
754 my $stash = $op->stash->NAME;
755 if ($stash ne $self->{'curstash'}) {
756 push @text, "package $stash;\n";
757 $self->{'curstash'} = $stash;
759 if ($self->{'linenums'}) {
760 push @text, "\f#line " . $op->line .
761 ' "' . substr($op->filegv->NAME, 2), qq'"\n';
763 return join("", @text);
766 sub pp_dbstate { pp_nextstate(@_) }
767 sub pp_setstate { pp_nextstate(@_) }
769 sub pp_unstack { return "" } # see also leaveloop
773 my($op, $cx, $name) = @_;
777 sub pp_stub { baseop(@_, "()") }
778 sub pp_wantarray { baseop(@_, "wantarray") }
779 sub pp_fork { baseop(@_, "fork") }
780 sub pp_wait { baseop(@_, "wait") }
781 sub pp_getppid { baseop(@_, "getppid") }
782 sub pp_time { baseop(@_, "time") }
783 sub pp_tms { baseop(@_, "times") }
784 sub pp_ghostent { baseop(@_, "gethostent") }
785 sub pp_gnetent { baseop(@_, "getnetent") }
786 sub pp_gprotoent { baseop(@_, "getprotoent") }
787 sub pp_gservent { baseop(@_, "getservent") }
788 sub pp_ehostent { baseop(@_, "endhostent") }
789 sub pp_enetent { baseop(@_, "endnetent") }
790 sub pp_eprotoent { baseop(@_, "endprotoent") }
791 sub pp_eservent { baseop(@_, "endservent") }
792 sub pp_gpwent { baseop(@_, "getpwent") }
793 sub pp_spwent { baseop(@_, "setpwent") }
794 sub pp_epwent { baseop(@_, "endpwent") }
795 sub pp_ggrent { baseop(@_, "getgrent") }
796 sub pp_sgrent { baseop(@_, "setgrent") }
797 sub pp_egrent { baseop(@_, "endgrent") }
798 sub pp_getlogin { baseop(@_, "getlogin") }
802 # I couldn't think of a good short name, but this is the category of
803 # symbolic unary operators with interesting precedence
807 my($op, $cx, $name, $prec, $flags) = (@_, 0);
808 my $kid = $op->first;
809 $kid = $self->deparse($kid, $prec);
810 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
814 sub pp_preinc { pfixop(@_, "++", 23) }
815 sub pp_predec { pfixop(@_, "--", 23) }
816 sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) }
817 sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) }
818 sub pp_i_preinc { pfixop(@_, "++", 23) }
819 sub pp_i_predec { pfixop(@_, "--", 23) }
820 sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) }
821 sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) }
822 sub pp_complement { pfixop(@_, "~", 21) }
827 if ($op->first->name =~ /^(i_)?negate$/) {
829 $self->pfixop($op, $cx, "-", 21.5);
831 $self->pfixop($op, $cx, "-", 21);
834 sub pp_i_negate { pp_negate(@_) }
840 $self->pfixop($op, $cx, "not ", 4);
842 $self->pfixop($op, $cx, "!", 21);
848 my($op, $cx, $name) = @_;
850 if ($op->flags & OPf_KIDS) {
852 return $self->maybe_parens_unop($name, $kid, $cx);
854 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
858 sub pp_chop { unop(@_, "chop") }
859 sub pp_chomp { unop(@_, "chomp") }
860 sub pp_schop { unop(@_, "chop") }
861 sub pp_schomp { unop(@_, "chomp") }
862 sub pp_defined { unop(@_, "defined") }
863 sub pp_undef { unop(@_, "undef") }
864 sub pp_study { unop(@_, "study") }
865 sub pp_ref { unop(@_, "ref") }
866 sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
868 sub pp_sin { unop(@_, "sin") }
869 sub pp_cos { unop(@_, "cos") }
870 sub pp_rand { unop(@_, "rand") }
871 sub pp_srand { unop(@_, "srand") }
872 sub pp_exp { unop(@_, "exp") }
873 sub pp_log { unop(@_, "log") }
874 sub pp_sqrt { unop(@_, "sqrt") }
875 sub pp_int { unop(@_, "int") }
876 sub pp_hex { unop(@_, "hex") }
877 sub pp_oct { unop(@_, "oct") }
878 sub pp_abs { unop(@_, "abs") }
880 sub pp_length { unop(@_, "length") }
881 sub pp_ord { unop(@_, "ord") }
882 sub pp_chr { unop(@_, "chr") }
884 sub pp_each { unop(@_, "each") }
885 sub pp_values { unop(@_, "values") }
886 sub pp_keys { unop(@_, "keys") }
887 sub pp_pop { unop(@_, "pop") }
888 sub pp_shift { unop(@_, "shift") }
890 sub pp_caller { unop(@_, "caller") }
891 sub pp_reset { unop(@_, "reset") }
892 sub pp_exit { unop(@_, "exit") }
893 sub pp_prototype { unop(@_, "prototype") }
895 sub pp_close { unop(@_, "close") }
896 sub pp_fileno { unop(@_, "fileno") }
897 sub pp_umask { unop(@_, "umask") }
898 sub pp_binmode { unop(@_, "binmode") }
899 sub pp_untie { unop(@_, "untie") }
900 sub pp_tied { unop(@_, "tied") }
901 sub pp_dbmclose { unop(@_, "dbmclose") }
902 sub pp_getc { unop(@_, "getc") }
903 sub pp_eof { unop(@_, "eof") }
904 sub pp_tell { unop(@_, "tell") }
905 sub pp_getsockname { unop(@_, "getsockname") }
906 sub pp_getpeername { unop(@_, "getpeername") }
908 sub pp_chdir { unop(@_, "chdir") }
909 sub pp_chroot { unop(@_, "chroot") }
910 sub pp_readlink { unop(@_, "readlink") }
911 sub pp_rmdir { unop(@_, "rmdir") }
912 sub pp_readdir { unop(@_, "readdir") }
913 sub pp_telldir { unop(@_, "telldir") }
914 sub pp_rewinddir { unop(@_, "rewinddir") }
915 sub pp_closedir { unop(@_, "closedir") }
916 sub pp_getpgrp { unop(@_, "getpgrp") }
917 sub pp_localtime { unop(@_, "localtime") }
918 sub pp_gmtime { unop(@_, "gmtime") }
919 sub pp_alarm { unop(@_, "alarm") }
920 sub pp_sleep { unop(@_, "sleep") }
922 sub pp_dofile { unop(@_, "do") }
923 sub pp_entereval { unop(@_, "eval") }
925 sub pp_ghbyname { unop(@_, "gethostbyname") }
926 sub pp_gnbyname { unop(@_, "getnetbyname") }
927 sub pp_gpbyname { unop(@_, "getprotobyname") }
928 sub pp_shostent { unop(@_, "sethostent") }
929 sub pp_snetent { unop(@_, "setnetent") }
930 sub pp_sprotoent { unop(@_, "setprotoent") }
931 sub pp_sservent { unop(@_, "setservent") }
932 sub pp_gpwnam { unop(@_, "getpwnam") }
933 sub pp_gpwuid { unop(@_, "getpwuid") }
934 sub pp_ggrnam { unop(@_, "getgrnam") }
935 sub pp_ggrgid { unop(@_, "getgrgid") }
937 sub pp_lock { unop(@_, "lock") }
942 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
950 if ($op->private & OPpSLICE) {
951 return $self->maybe_parens_func("delete",
952 $self->pp_hslice($op->first, 16),
955 return $self->maybe_parens_func("delete",
956 $self->pp_helem($op->first, 16),
964 if (class($op) eq "UNOP" and $op->first->name eq "const"
965 and $op->first->private & OPpCONST_BARE)
967 my $name = $op->first->sv->PV;
970 return "require($name)";
972 $self->unop($op, $cx, "require");
979 my $kid = $op->first;
980 if (not null $kid->sibling) {
982 return $self->dquote($op);
984 $self->unop(@_, "scalar");
991 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
997 my $kid = $op->first;
998 if ($kid->name eq "null") {
1000 if ($kid->name eq "anonlist" || $kid->name eq "anonhash") {
1001 my($pre, $post) = @{{"anonlist" => ["[","]"],
1002 "anonhash" => ["{","}"]}->{$kid->name}};
1004 $kid = $kid->first->sibling; # skip pushmark
1005 for (; !null($kid); $kid = $kid->sibling) {
1006 $expr = $self->deparse($kid, 6);
1009 return $pre . join(", ", @exprs) . $post;
1010 } elsif (!null($kid->sibling) and
1011 $kid->sibling->name eq "anoncode") {
1013 $self->deparse_sub($self->padval($kid->sibling->targ));
1014 } elsif ($kid->name eq "pushmark") {
1015 my $sib_name = $kid->sibling->name;
1016 if ($sib_name =~ /^(pad|rv2)[ah]v$/
1017 and not $kid->sibling->flags & OPf_REF)
1019 # The @a in \(@a) isn't in ref context, but only when the
1021 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
1022 } elsif ($sib_name eq 'entersub') {
1023 my $text = $self->deparse($kid->sibling, 1);
1024 # Always show parens for \(&func()), but only with -p otherwise
1025 $text = "($text)" if $self->{'parens'}
1026 or $kid->sibling->private & OPpENTERSUB_AMPER;
1031 $self->pfixop($op, $cx, "\\", 20);
1034 sub pp_srefgen { pp_refgen(@_) }
1039 my $kid = $op->first;
1040 $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
1041 return "<" . $self->deparse($kid, 1) . ">";
1044 # Unary operators that can occur as pseudo-listops inside double quotes
1047 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
1049 if ($op->flags & OPf_KIDS) {
1051 # If there's more than one kid, the first is an ex-pushmark.
1052 $kid = $kid->sibling if not null $kid->sibling;
1053 return $self->maybe_parens_unop($name, $kid, $cx);
1055 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
1059 sub pp_ucfirst { dq_unop(@_, "ucfirst") }
1060 sub pp_lcfirst { dq_unop(@_, "lcfirst") }
1061 sub pp_uc { dq_unop(@_, "uc") }
1062 sub pp_lc { dq_unop(@_, "lc") }
1063 sub pp_quotemeta { dq_unop(@_, "quotemeta") }
1067 my ($op, $cx, $name) = @_;
1068 if (class($op) eq "PVOP") {
1069 return "$name " . $op->pv;
1070 } elsif (class($op) eq "OP") {
1072 } elsif (class($op) eq "UNOP") {
1073 # Note -- loop exits are actually exempt from the
1074 # looks-like-a-func rule, but a few extra parens won't hurt
1075 return $self->maybe_parens_unop($name, $op->first, $cx);
1079 sub pp_last { loopex(@_, "last") }
1080 sub pp_next { loopex(@_, "next") }
1081 sub pp_redo { loopex(@_, "redo") }
1082 sub pp_goto { loopex(@_, "goto") }
1083 sub pp_dump { loopex(@_, "dump") }
1087 my($op, $cx, $name) = @_;
1088 if (class($op) eq "UNOP") {
1089 # Genuine `-X' filetests are exempt from the LLAFR, but not
1090 # l?stat(); for the sake of clarity, give'em all parens
1091 return $self->maybe_parens_unop($name, $op->first, $cx);
1092 } elsif (class($op) eq "GVOP") {
1093 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
1094 } else { # I don't think baseop filetests ever survive ck_ftst, but...
1099 sub pp_lstat { ftst(@_, "lstat") }
1100 sub pp_stat { ftst(@_, "stat") }
1101 sub pp_ftrread { ftst(@_, "-R") }
1102 sub pp_ftrwrite { ftst(@_, "-W") }
1103 sub pp_ftrexec { ftst(@_, "-X") }
1104 sub pp_fteread { ftst(@_, "-r") }
1105 sub pp_ftewrite { ftst(@_, "-r") }
1106 sub pp_fteexec { ftst(@_, "-r") }
1107 sub pp_ftis { ftst(@_, "-e") }
1108 sub pp_fteowned { ftst(@_, "-O") }
1109 sub pp_ftrowned { ftst(@_, "-o") }
1110 sub pp_ftzero { ftst(@_, "-z") }
1111 sub pp_ftsize { ftst(@_, "-s") }
1112 sub pp_ftmtime { ftst(@_, "-M") }
1113 sub pp_ftatime { ftst(@_, "-A") }
1114 sub pp_ftctime { ftst(@_, "-C") }
1115 sub pp_ftsock { ftst(@_, "-S") }
1116 sub pp_ftchr { ftst(@_, "-c") }
1117 sub pp_ftblk { ftst(@_, "-b") }
1118 sub pp_ftfile { ftst(@_, "-f") }
1119 sub pp_ftdir { ftst(@_, "-d") }
1120 sub pp_ftpipe { ftst(@_, "-p") }
1121 sub pp_ftlink { ftst(@_, "-l") }
1122 sub pp_ftsuid { ftst(@_, "-u") }
1123 sub pp_ftsgid { ftst(@_, "-g") }
1124 sub pp_ftsvtx { ftst(@_, "-k") }
1125 sub pp_fttty { ftst(@_, "-t") }
1126 sub pp_fttext { ftst(@_, "-T") }
1127 sub pp_ftbinary { ftst(@_, "-B") }
1129 sub SWAP_CHILDREN () { 1 }
1130 sub ASSIGN () { 2 } # has OP= variant
1136 my $name = $op->name;
1137 if ($name eq "concat" and $op->first->name eq "concat") {
1138 # avoid spurious `=' -- see comment in pp_concat
1141 if ($name eq "null" and class($op) eq "UNOP"
1142 and $op->first->name =~ /^(and|x?or)$/
1143 and null $op->first->sibling)
1145 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1146 # with a null that's used as the common end point of the two
1147 # flows of control. For precedence purposes, ignore it.
1148 # (COND_EXPRs have these too, but we don't bother with
1149 # their associativity).
1150 return assoc_class($op->first);
1152 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1155 # Left associative operators, like `+', for which
1156 # $a + $b + $c is equivalent to ($a + $b) + $c
1159 %left = ('multiply' => 19, 'i_multiply' => 19,
1160 'divide' => 19, 'i_divide' => 19,
1161 'modulo' => 19, 'i_modulo' => 19,
1163 'add' => 18, 'i_add' => 18,
1164 'subtract' => 18, 'i_subtract' => 18,
1166 'left_shift' => 17, 'right_shift' => 17,
1168 'bit_or' => 12, 'bit_xor' => 12,
1170 'or' => 2, 'xor' => 2,
1174 sub deparse_binop_left {
1176 my($op, $left, $prec) = @_;
1177 if ($left{assoc_class($op)}
1178 and $left{assoc_class($op)} == $left{assoc_class($left)})
1180 return $self->deparse($left, $prec - .00001);
1182 return $self->deparse($left, $prec);
1186 # Right associative operators, like `=', for which
1187 # $a = $b = $c is equivalent to $a = ($b = $c)
1190 %right = ('pow' => 22,
1191 'sassign=' => 7, 'aassign=' => 7,
1192 'multiply=' => 7, 'i_multiply=' => 7,
1193 'divide=' => 7, 'i_divide=' => 7,
1194 'modulo=' => 7, 'i_modulo=' => 7,
1196 'add=' => 7, 'i_add=' => 7,
1197 'subtract=' => 7, 'i_subtract=' => 7,
1199 'left_shift=' => 7, 'right_shift=' => 7,
1201 'bit_or=' => 7, 'bit_xor=' => 7,
1207 sub deparse_binop_right {
1209 my($op, $right, $prec) = @_;
1210 if ($right{assoc_class($op)}
1211 and $right{assoc_class($op)} == $right{assoc_class($right)})
1213 return $self->deparse($right, $prec - .00001);
1215 return $self->deparse($right, $prec);
1221 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
1222 my $left = $op->first;
1223 my $right = $op->last;
1225 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1229 if ($flags & SWAP_CHILDREN) {
1230 ($left, $right) = ($right, $left);
1232 $left = $self->deparse_binop_left($op, $left, $prec);
1233 $right = $self->deparse_binop_right($op, $right, $prec);
1234 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1237 sub pp_add { binop(@_, "+", 18, ASSIGN) }
1238 sub pp_multiply { binop(@_, "*", 19, ASSIGN) }
1239 sub pp_subtract { binop(@_, "-",18, ASSIGN) }
1240 sub pp_divide { binop(@_, "/", 19, ASSIGN) }
1241 sub pp_modulo { binop(@_, "%", 19, ASSIGN) }
1242 sub pp_i_add { binop(@_, "+", 18, ASSIGN) }
1243 sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) }
1244 sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) }
1245 sub pp_i_divide { binop(@_, "/", 19, ASSIGN) }
1246 sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) }
1247 sub pp_pow { binop(@_, "**", 22, ASSIGN) }
1249 sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) }
1250 sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) }
1251 sub pp_bit_and { binop(@_, "&", 13, ASSIGN) }
1252 sub pp_bit_or { binop(@_, "|", 12, ASSIGN) }
1253 sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) }
1255 sub pp_eq { binop(@_, "==", 14) }
1256 sub pp_ne { binop(@_, "!=", 14) }
1257 sub pp_lt { binop(@_, "<", 15) }
1258 sub pp_gt { binop(@_, ">", 15) }
1259 sub pp_ge { binop(@_, ">=", 15) }
1260 sub pp_le { binop(@_, "<=", 15) }
1261 sub pp_ncmp { binop(@_, "<=>", 14) }
1262 sub pp_i_eq { binop(@_, "==", 14) }
1263 sub pp_i_ne { binop(@_, "!=", 14) }
1264 sub pp_i_lt { binop(@_, "<", 15) }
1265 sub pp_i_gt { binop(@_, ">", 15) }
1266 sub pp_i_ge { binop(@_, ">=", 15) }
1267 sub pp_i_le { binop(@_, "<=", 15) }
1268 sub pp_i_ncmp { binop(@_, "<=>", 14) }
1270 sub pp_seq { binop(@_, "eq", 14) }
1271 sub pp_sne { binop(@_, "ne", 14) }
1272 sub pp_slt { binop(@_, "lt", 15) }
1273 sub pp_sgt { binop(@_, "gt", 15) }
1274 sub pp_sge { binop(@_, "ge", 15) }
1275 sub pp_sle { binop(@_, "le", 15) }
1276 sub pp_scmp { binop(@_, "cmp", 14) }
1278 sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1279 sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1281 # `.' is special because concats-of-concats are optimized to save copying
1282 # by making all but the first concat stacked. The effect is as if the
1283 # programmer had written `($a . $b) .= $c', except legal.
1287 my $left = $op->first;
1288 my $right = $op->last;
1291 if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
1295 $left = $self->deparse_binop_left($op, $left, $prec);
1296 $right = $self->deparse_binop_right($op, $right, $prec);
1297 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
1300 # `x' is weird when the left arg is a list
1304 my $left = $op->first;
1305 my $right = $op->last;
1308 if ($op->flags & OPf_STACKED) {
1312 if (null($right)) { # list repeat; count is inside left-side ex-list
1313 my $kid = $left->first->sibling; # skip pushmark
1315 for (; !null($kid->sibling); $kid = $kid->sibling) {
1316 push @exprs, $self->deparse($kid, 6);
1319 $left = "(" . join(", ", @exprs). ")";
1321 $left = $self->deparse_binop_left($op, $left, $prec);
1323 $right = $self->deparse_binop_right($op, $right, $prec);
1324 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
1329 my ($op, $cx, $type) = @_;
1330 my $left = $op->first;
1331 my $right = $left->sibling;
1332 $left = $self->deparse($left, 9);
1333 $right = $self->deparse($right, 9);
1334 return $self->maybe_parens("$left $type $right", $cx, 9);
1340 my $flip = $op->first;
1341 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
1342 return $self->range($flip->first, $cx, $type);
1345 # one-line while/until is handled in pp_leave
1349 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
1350 my $left = $op->first;
1351 my $right = $op->first->sibling;
1352 if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1353 $left = $self->deparse($left, 1);
1354 $right = $self->deparse($right, 0);
1355 return "$blockname ($left) {\n\t$right\n\b}\cK";
1356 } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1357 $right = $self->deparse($right, 1);
1358 $left = $self->deparse($left, 1);
1359 return "$right $blockname $left";
1360 } elsif ($cx > $lowprec and $highop) { # $a && $b
1361 $left = $self->deparse_binop_left($op, $left, $highprec);
1362 $right = $self->deparse_binop_right($op, $right, $highprec);
1363 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1364 } else { # $a and $b
1365 $left = $self->deparse_binop_left($op, $left, $lowprec);
1366 $right = $self->deparse_binop_right($op, $right, $lowprec);
1367 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1371 sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1372 sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1373 sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
1377 my ($op, $cx, $opname) = @_;
1378 my $left = $op->first;
1379 my $right = $op->first->sibling->first; # skip sassign
1380 $left = $self->deparse($left, 7);
1381 $right = $self->deparse($right, 7);
1382 return $self->maybe_parens("$left $opname $right", $cx, 7);
1385 sub pp_andassign { logassignop(@_, "&&=") }
1386 sub pp_orassign { logassignop(@_, "||=") }
1390 my($op, $cx, $name) = @_;
1392 my $parens = ($cx >= 5) || $self->{'parens'};
1393 my $kid = $op->first->sibling;
1394 return $name if null $kid;
1395 my $first = $self->deparse($kid, 6);
1396 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1397 push @exprs, $first;
1398 $kid = $kid->sibling;
1399 for (; !null($kid); $kid = $kid->sibling) {
1400 push @exprs, $self->deparse($kid, 6);
1403 return "$name(" . join(", ", @exprs) . ")";
1405 return "$name " . join(", ", @exprs);
1409 sub pp_bless { listop(@_, "bless") }
1410 sub pp_atan2 { listop(@_, "atan2") }
1411 sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1412 sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1413 sub pp_index { listop(@_, "index") }
1414 sub pp_rindex { listop(@_, "rindex") }
1415 sub pp_sprintf { listop(@_, "sprintf") }
1416 sub pp_formline { listop(@_, "formline") } # see also deparse_format
1417 sub pp_crypt { listop(@_, "crypt") }
1418 sub pp_unpack { listop(@_, "unpack") }
1419 sub pp_pack { listop(@_, "pack") }
1420 sub pp_join { listop(@_, "join") }
1421 sub pp_splice { listop(@_, "splice") }
1422 sub pp_push { listop(@_, "push") }
1423 sub pp_unshift { listop(@_, "unshift") }
1424 sub pp_reverse { listop(@_, "reverse") }
1425 sub pp_warn { listop(@_, "warn") }
1426 sub pp_die { listop(@_, "die") }
1427 # Actually, return is exempt from the LLAFR (see examples in this very
1428 # module!), but for consistency's sake, ignore that fact
1429 sub pp_return { listop(@_, "return") }
1430 sub pp_open { listop(@_, "open") }
1431 sub pp_pipe_op { listop(@_, "pipe") }
1432 sub pp_tie { listop(@_, "tie") }
1433 sub pp_dbmopen { listop(@_, "dbmopen") }
1434 sub pp_sselect { listop(@_, "select") }
1435 sub pp_select { listop(@_, "select") }
1436 sub pp_read { listop(@_, "read") }
1437 sub pp_sysopen { listop(@_, "sysopen") }
1438 sub pp_sysseek { listop(@_, "sysseek") }
1439 sub pp_sysread { listop(@_, "sysread") }
1440 sub pp_syswrite { listop(@_, "syswrite") }
1441 sub pp_send { listop(@_, "send") }
1442 sub pp_recv { listop(@_, "recv") }
1443 sub pp_seek { listop(@_, "seek") }
1444 sub pp_fcntl { listop(@_, "fcntl") }
1445 sub pp_ioctl { listop(@_, "ioctl") }
1446 sub pp_flock { listop(@_, "flock") }
1447 sub pp_socket { listop(@_, "socket") }
1448 sub pp_sockpair { listop(@_, "sockpair") }
1449 sub pp_bind { listop(@_, "bind") }
1450 sub pp_connect { listop(@_, "connect") }
1451 sub pp_listen { listop(@_, "listen") }
1452 sub pp_accept { listop(@_, "accept") }
1453 sub pp_shutdown { listop(@_, "shutdown") }
1454 sub pp_gsockopt { listop(@_, "getsockopt") }
1455 sub pp_ssockopt { listop(@_, "setsockopt") }
1456 sub pp_chown { listop(@_, "chown") }
1457 sub pp_unlink { listop(@_, "unlink") }
1458 sub pp_chmod { listop(@_, "chmod") }
1459 sub pp_utime { listop(@_, "utime") }
1460 sub pp_rename { listop(@_, "rename") }
1461 sub pp_link { listop(@_, "link") }
1462 sub pp_symlink { listop(@_, "symlink") }
1463 sub pp_mkdir { listop(@_, "mkdir") }
1464 sub pp_open_dir { listop(@_, "opendir") }
1465 sub pp_seekdir { listop(@_, "seekdir") }
1466 sub pp_waitpid { listop(@_, "waitpid") }
1467 sub pp_system { listop(@_, "system") }
1468 sub pp_exec { listop(@_, "exec") }
1469 sub pp_kill { listop(@_, "kill") }
1470 sub pp_setpgrp { listop(@_, "setpgrp") }
1471 sub pp_getpriority { listop(@_, "getpriority") }
1472 sub pp_setpriority { listop(@_, "setpriority") }
1473 sub pp_shmget { listop(@_, "shmget") }
1474 sub pp_shmctl { listop(@_, "shmctl") }
1475 sub pp_shmread { listop(@_, "shmread") }
1476 sub pp_shmwrite { listop(@_, "shmwrite") }
1477 sub pp_msgget { listop(@_, "msgget") }
1478 sub pp_msgctl { listop(@_, "msgctl") }
1479 sub pp_msgsnd { listop(@_, "msgsnd") }
1480 sub pp_msgrcv { listop(@_, "msgrcv") }
1481 sub pp_semget { listop(@_, "semget") }
1482 sub pp_semctl { listop(@_, "semctl") }
1483 sub pp_semop { listop(@_, "semop") }
1484 sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1485 sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1486 sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1487 sub pp_gsbyname { listop(@_, "getservbyname") }
1488 sub pp_gsbyport { listop(@_, "getservbyport") }
1489 sub pp_syscall { listop(@_, "syscall") }
1494 my $text = $self->dq($op->first->sibling); # skip pushmark
1495 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1496 or $text =~ /[<>]/) {
1497 return 'glob(' . single_delim('qq', '"', $text) . ')';
1499 return '<' . $text . '>';
1503 # Truncate is special because OPf_SPECIAL makes a bareword first arg
1504 # be a filehandle. This could probably be better fixed in the core
1505 # by moving the GV lookup into ck_truc.
1511 my $parens = ($cx >= 5) || $self->{'parens'};
1512 my $kid = $op->first->sibling;
1514 if ($op->flags & OPf_SPECIAL) {
1515 # $kid is an OP_CONST
1518 $fh = $self->deparse($kid, 6);
1519 $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
1521 my $len = $self->deparse($kid->sibling, 6);
1523 return "truncate($fh, $len)";
1525 return "truncate $fh, $len";
1531 my($op, $cx, $name) = @_;
1533 my $kid = $op->first->sibling;
1535 if ($op->flags & OPf_STACKED) {
1537 $indir = $indir->first; # skip rv2gv
1538 if (is_scope($indir)) {
1539 $indir = "{" . $self->deparse($indir, 0) . "}";
1541 $indir = $self->deparse($indir, 24);
1543 $indir = $indir . " ";
1544 $kid = $kid->sibling;
1546 for (; !null($kid); $kid = $kid->sibling) {
1547 $expr = $self->deparse($kid, 6);
1550 return $self->maybe_parens_func($name,
1551 $indir . join(", ", @exprs),
1555 sub pp_prtf { indirop(@_, "printf") }
1556 sub pp_print { indirop(@_, "print") }
1557 sub pp_sort { indirop(@_, "sort") }
1561 my($op, $cx, $name) = @_;
1563 my $kid = $op->first; # this is the (map|grep)start
1564 $kid = $kid->first->sibling; # skip a pushmark
1565 my $code = $kid->first; # skip a null
1566 if (is_scope $code) {
1567 $code = "{" . $self->deparse($code, 0) . "} ";
1569 $code = $self->deparse($code, 24) . ", ";
1571 $kid = $kid->sibling;
1572 for (; !null($kid); $kid = $kid->sibling) {
1573 $expr = $self->deparse($kid, 6);
1574 push @exprs, $expr if $expr;
1576 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
1579 sub pp_mapwhile { mapop(@_, "map") }
1580 sub pp_grepwhile { mapop(@_, "grep") }
1586 my $kid = $op->first->sibling; # skip pushmark
1588 my $local = "either"; # could be local(...) or my(...)
1589 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1590 # This assumes that no other private flags equal 128, and that
1591 # OPs that store things other than flags in their op_private,
1592 # like OP_AELEMFAST, won't be immediate children of a list.
1593 unless ($lop->private & OPpLVAL_INTRO or $lop->name eq "undef")
1595 $local = ""; # or not
1598 if ($lop->name =~ /^pad[ash]v$/) { # my()
1599 ($local = "", last) if $local eq "local";
1601 } elsif ($lop->name ne "undef") { # local()
1602 ($local = "", last) if $local eq "my";
1606 $local = "" if $local eq "either"; # no point if it's all undefs
1607 return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
1608 for (; !null($kid); $kid = $kid->sibling) {
1610 if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
1615 $self->{'avoid_local'}{$$lop}++;
1616 $expr = $self->deparse($kid, 6);
1617 delete $self->{'avoid_local'}{$$lop};
1619 $expr = $self->deparse($kid, 6);
1624 return "$local(" . join(", ", @exprs) . ")";
1626 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1633 my $cond = $op->first;
1634 my $true = $cond->sibling;
1635 my $false = $true->sibling;
1636 my $cuddle = $self->{'cuddle'};
1637 unless ($cx == 0 and is_scope($true) and is_scope($false)) {
1638 $cond = $self->deparse($cond, 8);
1639 $true = $self->deparse($true, 8);
1640 $false = $self->deparse($false, 8);
1641 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1643 $cond = $self->deparse($cond, 1);
1644 $true = $self->deparse($true, 0);
1645 if ($false->name eq "lineseq") { # braces w/o scope => elsif
1646 my $head = "if ($cond) {\n\t$true\n\b}";
1648 while (!null($false) and $false->name eq "lineseq") {
1649 my $newop = $false->first->sibling->first;
1650 my $newcond = $newop->first;
1651 my $newtrue = $newcond->sibling;
1652 $false = $newtrue->sibling; # last in chain is OP_AND => no else
1653 $newcond = $self->deparse($newcond, 1);
1654 $newtrue = $self->deparse($newtrue, 0);
1655 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1657 if (!null($false)) {
1658 $false = $cuddle . "else {\n\t" .
1659 $self->deparse($false, 0) . "\n\b}\cK";
1663 return $head . join($cuddle, "", @elsifs) . $false;
1665 $false = $self->deparse($false, 0);
1666 return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
1672 my $enter = $op->first;
1673 my $kid = $enter->sibling;
1674 local($self->{'curstash'}) = $self->{'curstash'};
1677 if ($kid->name eq "lineseq") { # bare or infinite loop
1678 if (is_state $kid->last) { # infinite
1679 $head = "for (;;) "; # shorter than while (1)
1683 } elsif ($enter->name eq "enteriter") { # foreach
1684 my $ary = $enter->first->sibling; # first was pushmark
1685 my $var = $ary->sibling;
1686 if ($enter->flags & OPf_STACKED
1687 and not null $ary->first->sibling->sibling)
1689 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1690 $self->deparse($ary->first->sibling->sibling, 9);
1692 $ary = $self->deparse($ary, 1);
1695 if ($enter->flags & OPf_SPECIAL) { # thread special var
1696 $var = $self->pp_threadsv($enter, 1);
1697 } else { # regular my() variable
1698 $var = $self->pp_padsv($enter, 1);
1699 if ($self->padname_sv($enter->targ)->IVX ==
1700 $kid->first->first->sibling->last->cop_seq)
1702 # If the scope of this variable closes at the last
1703 # statement of the loop, it must have been
1705 $var = "my " . $var;
1708 } elsif ($var->name eq "rv2gv") {
1709 $var = $self->pp_rv2sv($var, 1);
1710 } elsif ($var->name eq "gv") {
1711 $var = "\$" . $self->deparse($var, 1);
1713 $head = "foreach $var ($ary) ";
1714 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1715 } elsif ($kid->name eq "null") { # while/until
1717 my $name = {"and" => "while", "or" => "until"}
1719 $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
1720 $kid = $kid->first->sibling;
1721 } elsif ($kid->name eq "stub") { # bare and empty
1722 return "{;}"; # {} could be a hashref
1724 # The third-to-last kid is the continue block if the pointer used
1725 # by `next BLOCK' points to its first OP, which happens to be the
1726 # the op_next of the head of the _previous_ statement.
1727 # Unless it's a bare loop, in which case it's last, since there's
1728 # no unstack or extra nextstate.
1729 # Except if the previous head isn't null but the first kid is
1730 # (because it's a nulled out nextstate in a scope), in which
1731 # case the head's next is advanced past the null but the nextop's
1732 # isn't, so we need to try nextop->next.
1734 my $cont = $kid->first;
1736 while (!null($cont->sibling)) {
1738 $cont = $cont->sibling;
1741 while (!null($cont->sibling->sibling->sibling)) {
1743 $cont = $cont->sibling;
1746 if ($precont and $ {$precont->next} == $ {$enter->nextop}
1747 || $ {$precont->next} == $ {$enter->nextop->next} )
1749 my $state = $kid->first;
1750 my $cuddle = $self->{'cuddle'};
1752 for (; $$state != $$cont; $state = $state->sibling) {
1754 if (is_state $state) {
1755 $expr = $self->deparse($state, 0);
1756 $state = $state->sibling;
1759 $expr .= $self->deparse($state, 0);
1760 push @exprs, $expr if $expr;
1762 $kid = join(";\n", @exprs);
1763 $cont = $cuddle . "continue {\n\t" .
1764 $self->deparse($cont, 0) . "\n\b}\cK";
1767 $kid = $self->deparse($kid, 0);
1769 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1774 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
1777 BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
1778 BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
1783 if (class($op) eq "OP") {
1785 return $self->{'ex_const'} if $op->targ == OP_CONST;
1786 } elsif ($op->first->name eq "pushmark") {
1787 return $self->pp_list($op, $cx);
1788 } elsif ($op->first->name eq "enter") {
1789 return $self->pp_leave($op, $cx);
1790 } elsif ($op->targ == OP_STRINGIFY) {
1791 return $self->dquote($op);
1792 } elsif (!null($op->first->sibling) and
1793 $op->first->sibling->name eq "readline" and
1794 $op->first->sibling->flags & OPf_STACKED) {
1795 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1796 . $self->deparse($op->first->sibling, 7),
1798 } elsif (!null($op->first->sibling) and
1799 $op->first->sibling->name eq "trans" and
1800 $op->first->sibling->flags & OPf_STACKED) {
1801 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1802 . $self->deparse($op->first->sibling, 20),
1805 return $self->deparse($op->first, $cx);
1809 # the aassign in-common check messes up SvCUR (always setting it
1810 # to a value >= 100), but it's probably safe to assume there
1811 # won't be any NULs in the names of my() variables. (with
1812 # stash variables, I wouldn't be so sure)
1815 $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
1822 my $str = $self->padname_sv($targ)->PV;
1823 return padname_fix($str);
1829 return substr($self->padname($op->targ), 1); # skip $/@/%
1835 return $self->maybe_my($op, $cx, $self->padname($op->targ));
1838 sub pp_padav { pp_padsv(@_) }
1839 sub pp_padhv { pp_padsv(@_) }
1844 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1845 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1846 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1853 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
1859 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
1865 return $self->gv_name($op->gv);
1872 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1877 my($op, $cx, $type) = @_;
1878 my $kid = $op->first;
1879 my $str = $self->deparse($kid, 0);
1880 return $type . (is_scalar($kid) ? $str : "{$str}");
1883 sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1884 sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1885 sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1891 if ($op->first->name eq "padav") {
1892 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
1894 return $self->maybe_local($op, $cx,
1895 $self->rv2x($op->first, $cx, '$#'));
1899 # skip down to the old, ex-rv2cv
1900 sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
1905 my $kid = $op->first;
1906 if ($kid->name eq "const") { # constant list
1908 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1910 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
1917 my ($op, $cx, $left, $right, $padname) = @_;
1918 my($array, $idx) = ($op->first, $op->first->sibling);
1919 unless ($array->name eq $padname) { # Maybe this has been fixed
1920 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1922 if ($array->name eq $padname) {
1923 $array = $self->padany($array);
1924 } elsif (is_scope($array)) { # ${expr}[0]
1925 $array = "{" . $self->deparse($array, 0) . "}";
1926 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
1927 $array = $self->deparse($array, 24);
1929 # $x[20][3]{hi} or expr->[20]
1931 $arrow = "->" if $array->name !~ /^[ah]elem$/;
1932 return $self->deparse($array, 24) . $arrow .
1933 $left . $self->deparse($idx, 1) . $right;
1935 $idx = $self->deparse($idx, 1);
1936 return "\$" . $array . $left . $idx . $right;
1939 sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
1940 sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
1945 my($glob, $part) = ($op->first, $op->last);
1946 $glob = $glob->first; # skip rv2gv
1947 $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
1948 my $scope = is_scope($glob);
1949 $glob = $self->deparse($glob, 0);
1950 $part = $self->deparse($part, 1);
1951 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1956 my ($op, $cx, $left, $right, $regname, $padname) = @_;
1958 my(@elems, $kid, $array, $list);
1959 if (class($op) eq "LISTOP") {
1961 } else { # ex-hslice inside delete()
1962 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
1966 $array = $array->first
1967 if $array->name eq $regname or $array->name eq "null";
1968 if (is_scope($array)) {
1969 $array = "{" . $self->deparse($array, 0) . "}";
1970 } elsif ($array->name eq $padname) {
1971 $array = $self->padany($array);
1973 $array = $self->deparse($array, 24);
1975 $kid = $op->first->sibling; # skip pushmark
1976 if ($kid->name eq "list") {
1977 $kid = $kid->first->sibling; # skip list, pushmark
1978 for (; !null $kid; $kid = $kid->sibling) {
1979 push @elems, $self->deparse($kid, 6);
1981 $list = join(", ", @elems);
1983 $list = $self->deparse($kid, 1);
1985 return "\@" . $array . $left . $list . $right;
1988 sub pp_aslice { maybe_local(@_, slice(@_, "[", "]",
1989 "rv2av", "padav")) }
1990 sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
1991 "rv2hv", "padhv")) }
1996 my $idx = $op->first;
1997 my $list = $op->last;
1999 $list = $self->deparse($list, 1);
2000 $idx = $self->deparse($idx, 1);
2001 return "($list)" . "[$idx]";
2006 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
2011 return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
2017 my $kid = $op->first->sibling; # skip pushmark
2018 my($meth, $obj, @exprs);
2019 if ($kid->name eq "list" and want_list $kid) {
2020 # When an indirect object isn't a bareword but the args are in
2021 # parens, the parens aren't part of the method syntax (the LLAFR
2022 # doesn't apply), but they make a list with OPf_PARENS set that
2023 # doesn't get flattened by the append_elem that adds the method,
2024 # making a (object, arg1, arg2, ...) list where the object
2025 # usually is. This can be distinguished from
2026 # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
2027 # object) because in the later the list is in scalar context
2028 # as the left side of -> always is, while in the former
2029 # the list is in list context as method arguments always are.
2030 # (Good thing there aren't method prototypes!)
2031 $meth = $kid->sibling->first;
2032 $kid = $kid->first->sibling; # skip pushmark
2034 $kid = $kid->sibling;
2035 for (; not null $kid; $kid = $kid->sibling) {
2036 push @exprs, $self->deparse($kid, 6);
2040 $kid = $kid->sibling;
2041 for (; not null $kid->sibling; $kid = $kid->sibling) {
2042 push @exprs, $self->deparse($kid, 6);
2044 $meth = $kid->first;
2046 $obj = $self->deparse($obj, 24);
2047 if ($meth->name eq "const") {
2048 $meth = $meth->sv->PV; # needs to be bare
2050 $meth = $self->deparse($meth, 1);
2052 my $args = join(", ", @exprs);
2053 $kid = $obj . "->" . $meth;
2055 return $kid . "(" . $args . ")"; # parens mandatory
2061 # returns "&" if the prototype doesn't match the args,
2062 # or ("", $args_after_prototype_demunging) if it does.
2065 my($proto, @args) = @_;
2069 # An unbackslashed @ or % gobbles up the rest of the args
2070 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
2072 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
2075 return "&" if @args;
2076 } elsif ($chr eq ";") {
2078 } elsif ($chr eq "@" or $chr eq "%") {
2079 push @reals, map($self->deparse($_, 6), @args);
2085 if (want_scalar $arg) {
2086 push @reals, $self->deparse($arg, 6);
2090 } elsif ($chr eq "&") {
2091 if ($arg->name =~ /^(s?refgen|undef)$/) {
2092 push @reals, $self->deparse($arg, 6);
2096 } elsif ($chr eq "*") {
2097 if ($arg->name =~ /^s?refgen$/
2098 and $arg->first->first->name eq "rv2gv")
2100 $real = $arg->first->first; # skip refgen, null
2101 if ($real->first->name eq "gv") {
2102 push @reals, $self->deparse($real, 6);
2104 push @reals, $self->deparse($real->first, 6);
2109 } elsif (substr($chr, 0, 1) eq "\\") {
2110 $chr = substr($chr, 1);
2111 if ($arg->name =~ /^s?refgen$/ and
2112 !null($real = $arg->first) and
2113 ($chr eq "\$" && is_scalar($real->first)
2115 && $real->first->sibling->name
2118 && $real->first->sibling->name
2120 #or ($chr eq "&" # This doesn't work
2121 # && $real->first->name eq "rv2cv")
2123 && $real->first->name eq "rv2gv")))
2125 push @reals, $self->deparse($real, 6);
2132 return "&" if $proto and !$doneok; # too few args and no `;'
2133 return "&" if @args; # too many args
2134 return ("", join ", ", @reals);
2140 return $self->method($op, $cx) unless null $op->first->sibling;
2144 if ($op->flags & OPf_SPECIAL) {
2146 } elsif ($op->private & OPpENTERSUB_AMPER) {
2150 $kid = $kid->first->sibling; # skip ex-list, pushmark
2151 for (; not null $kid->sibling; $kid = $kid->sibling) {
2156 if (is_scope($kid)) {
2158 $kid = "{" . $self->deparse($kid, 0) . "}";
2159 } elsif ($kid->first->name eq "gv") {
2160 my $gv = $kid->first->gv;
2161 if (class($gv->CV) ne "SPECIAL") {
2162 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
2164 $simple = 1; # only calls of named functions can be prototyped
2165 $kid = $self->deparse($kid, 24);
2166 } elsif (is_scalar $kid->first) {
2168 $kid = $self->deparse($kid, 24);
2171 $kid = $self->deparse($kid, 24) . "->";
2174 if (defined $proto and not $amper) {
2175 ($amper, $args) = $self->check_proto($proto, @exprs);
2176 if ($amper eq "&") {
2177 $args = join(", ", map($self->deparse($_, 6), @exprs));
2180 $args = join(", ", map($self->deparse($_, 6), @exprs));
2182 if ($prefix or $amper) {
2183 if ($op->flags & OPf_STACKED) {
2184 return $prefix . $amper . $kid . "(" . $args . ")";
2186 return $prefix . $amper. $kid;
2189 if (defined $proto and $proto eq "") {
2191 } elsif ($proto eq "\$") {
2192 return $self->maybe_parens_func($kid, $args, $cx, 16);
2193 } elsif ($proto or $simple) {
2194 return $self->maybe_parens_func($kid, $args, $cx, 5);
2196 return "$kid(" . $args . ")";
2201 sub pp_enterwrite { unop(@_, "write") }
2203 # escape things that cause interpolation in double quotes,
2204 # but not character escapes
2207 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2211 # the same, but treat $|, $), and $ at the end of the string differently
2214 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2215 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
2219 # character escapes, but not delimiters that might need to be escaped
2220 sub escape_str { # ASCII
2223 # $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2229 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2230 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2234 # Don't do this for regexen
2237 $str =~ s/\\/\\\\/g;
2241 sub balanced_delim {
2243 my @str = split //, $str;
2244 my($ar, $open, $close, $fail, $c, $cnt);
2245 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2246 ($open, $close) = @$ar;
2247 $fail = 0; $cnt = 0;
2251 } elsif ($c eq $close) {
2260 $fail = 1 if $cnt != 0;
2261 return ($open, "$open$str$close") if not $fail;
2267 my($q, $default, $str) = @_;
2268 return "$default$str$default" if $default and index($str, $default) == -1;
2269 my($succeed, $delim);
2270 ($succeed, $str) = balanced_delim($str);
2271 return "$q$str" if $succeed;
2272 for $delim ('/', '"', '#') {
2273 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2276 $str =~ s/$default/\\$default/g;
2277 return "$default$str$default";
2286 if (class($sv) eq "SPECIAL") {
2287 return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
2288 } elsif ($sv->FLAGS & SVf_IOK) {
2290 } elsif ($sv->FLAGS & SVf_NOK) {
2292 } elsif ($sv->FLAGS & SVf_ROK) {
2293 return "\\(" . const($sv->RV) . ")"; # constant folded
2296 if ($str =~ /[^ -~]/) { # ASCII for non-printing
2297 return single_delim("qq", '"', uninterp escape_str unback $str);
2299 return single_delim("q", "'", unback $str);
2307 # if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
2308 # return $op->sv->PV;
2310 return const($op->sv);
2316 my $type = $op->name;
2317 if ($type eq "const") {
2318 return uninterp(escape_str(unback($op->sv->PV)));
2319 } elsif ($type eq "concat") {
2320 return $self->dq($op->first) . $self->dq($op->last);
2321 } elsif ($type eq "uc") {
2322 return '\U' . $self->dq($op->first->sibling) . '\E';
2323 } elsif ($type eq "lc") {
2324 return '\L' . $self->dq($op->first->sibling) . '\E';
2325 } elsif ($type eq "ucfirst") {
2326 return '\u' . $self->dq($op->first->sibling);
2327 } elsif ($type eq "lcfirst") {
2328 return '\l' . $self->dq($op->first->sibling);
2329 } elsif ($type eq "quotemeta") {
2330 return '\Q' . $self->dq($op->first->sibling) . '\E';
2331 } elsif ($type eq "join") {
2332 return $self->deparse($op->last, 26); # was join($", @ary)
2334 return $self->deparse($op, 26);
2342 return single_delim("qx", '`', $self->dq($op->first->sibling));
2347 my($op, $cx) = shift;
2348 return $self->deparse($op->first->sibling, $cx) if $self->{'unquote'};
2349 # skip ex-stringify, pushmark
2350 return single_delim("qq", '"', $self->dq($op->first->sibling));
2353 # OP_STRINGIFY is a listop, but it only ever has one arg
2354 sub pp_stringify { dquote(@_) }
2356 # tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2357 # note that tr(from)/to/ is OK, but not tr/from/(to)
2359 my($from, $to) = @_;
2360 my($succeed, $delim);
2361 if ($from !~ m[/] and $to !~ m[/]) {
2362 return "/$from/$to/";
2363 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2364 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2367 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2368 return "$from$delim$to$delim" if index($to, $delim) == -1;
2371 return "$from/$to/";
2374 for $delim ('/', '"', '#') { # note no '
2375 return "$delim$from$delim$to$delim"
2376 if index($to . $from, $delim) == -1;
2378 $from =~ s[/][\\/]g;
2380 return "/$from/$to/";
2386 if ($n == ord '\\') {
2388 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2390 } elsif ($n == ord "\a") {
2392 } elsif ($n == ord "\b") {
2394 } elsif ($n == ord "\t") {
2396 } elsif ($n == ord "\n") {
2398 } elsif ($n == ord "\e") {
2400 } elsif ($n == ord "\f") {
2402 } elsif ($n == ord "\r") {
2404 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2405 return '\\c' . chr(ord("@") + $n);
2407 # return '\x' . sprintf("%02x", $n);
2408 return '\\' . sprintf("%03o", $n);
2415 for ($c = 0; $c < @chars; $c++) {
2418 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2419 $chars[$c + 2] == $tr + 2)
2421 for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
2424 $str .= pchr($chars[$c]);
2430 # XXX This has trouble with hyphens in the replacement (tr/bac/-AC/),
2433 sub tr_decode_byte {
2434 my($table, $flags) = @_;
2435 my(@table) = unpack("s256", $table);
2436 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2437 if ($table[ord "-"] != -1 and
2438 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2440 $tr = $table[ord "-"];
2441 $table[ord "-"] = -1;
2445 } else { # -2 ==> delete
2449 for ($c = 0; $c < 256; $c++) {
2452 push @from, $c; push @to, $tr;
2453 } elsif ($tr == -2) {
2457 @from = (@from, @delfrom);
2458 if ($flags & OPpTRANS_COMPLEMENT) {
2461 @from{@from} = (1) x @from;
2462 for ($c = 0; $c < 256; $c++) {
2463 push @newfrom, $c unless $from{$c};
2467 unless ($flags & OPpTRANS_DELETE) {
2468 pop @to while $#to and $to[$#to] == $to[$#to -1];
2471 $from = collapse(@from);
2472 $to = collapse(@to);
2473 $from .= "-" if $delhyphen;
2474 return ($from, $to);
2479 if ($x == ord "-") {
2486 # XXX This doesn't yet handle all cases correctly either
2488 sub tr_decode_utf8 {
2489 my($swash_hv, $flags) = @_;
2490 my %swash = $swash_hv->ARRAY;
2492 $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
2493 my $none = $swash{"NONE"}->IV;
2494 my $extra = $none + 1;
2495 my(@from, @delfrom, @to);
2497 foreach $line (split /\n/, $swash{'LIST'}->PV) {
2498 my($min, $max, $result) = split(/\t/, $line);
2505 $result = hex $result;
2506 if ($result == $extra) {
2507 push @delfrom, [$min, $max];
2509 push @from, [$min, $max];
2510 push @to, [$result, $result + $max - $min];
2513 for my $i (0 .. $#from) {
2514 if ($from[$i][0] == ord '-') {
2515 unshift @from, splice(@from, $i, 1);
2516 unshift @to, splice(@to, $i, 1);
2518 } elsif ($from[$i][1] == ord '-') {
2521 unshift @from, ord '-';
2522 unshift @to, ord '-';
2526 for my $i (0 .. $#delfrom) {
2527 if ($delfrom[$i][0] == ord '-') {
2528 push @delfrom, splice(@delfrom, $i, 1);
2530 } elsif ($delfrom[$i][1] == ord '-') {
2532 push @delfrom, ord '-';
2536 if (defined $final and $to[$#to][1] != $final) {
2537 push @to, [$final, $final];
2539 push @from, @delfrom;
2540 if ($flags & OPpTRANS_COMPLEMENT) {
2543 for my $i (0 .. $#from) {
2544 push @newfrom, [$next, $from[$i][0] - 1];
2545 $next = $from[$i][1] + 1;
2548 for my $range (@newfrom) {
2549 if ($range->[0] <= $range->[1]) {
2554 my($from, $to, $diff);
2555 for my $chunk (@from) {
2556 $diff = $chunk->[1] - $chunk->[0];
2558 $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2559 } elsif ($diff == 1) {
2560 $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2562 $from .= tr_chr($chunk->[0]);
2565 for my $chunk (@to) {
2566 $diff = $chunk->[1] - $chunk->[0];
2568 $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
2569 } elsif ($diff == 1) {
2570 $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
2572 $to .= tr_chr($chunk->[0]);
2575 #$final = sprintf("%04x", $final) if defined $final;
2576 #$none = sprintf("%04x", $none) if defined $none;
2577 #$extra = sprintf("%04x", $extra) if defined $extra;
2578 #print STDERR "final: $final\n none: $none\nextra: $extra\n";
2579 #print STDERR $swash{'LIST'}->PV;
2580 return (escape_str($from), escape_str($to));
2587 if (class($op) eq "PVOP") {
2588 ($from, $to) = tr_decode_byte($op->pv, $op->private);
2589 } else { # class($op) eq "SVOP"
2590 ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
2593 $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
2594 $flags .= "d" if $op->private & OPpTRANS_DELETE;
2595 $to = "" if $from eq $to and $flags eq "";
2596 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2597 return "tr" . double_delim($from, $to) . $flags;
2600 # Like dq(), but different
2604 my $type = $op->name;
2605 if ($type eq "const") {
2606 return uninterp($op->sv->PV);
2607 } elsif ($type eq "concat") {
2608 return $self->re_dq($op->first) . $self->re_dq($op->last);
2609 } elsif ($type eq "uc") {
2610 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2611 } elsif ($type eq "lc") {
2612 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2613 } elsif ($type eq "ucfirst") {
2614 return '\u' . $self->re_dq($op->first->sibling);
2615 } elsif ($type eq "lcfirst") {
2616 return '\l' . $self->re_dq($op->first->sibling);
2617 } elsif ($type eq "quotemeta") {
2618 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2619 } elsif ($type eq "join") {
2620 return $self->deparse($op->last, 26); # was join($", @ary)
2622 return $self->deparse($op, 26);
2629 my $kid = $op->first;
2630 $kid = $kid->first if $kid->name eq "regcmaybe";
2631 $kid = $kid->first if $kid->name eq "regcreset";
2632 return $self->re_dq($kid);
2635 # osmic acid -- see osmium tetroxide
2638 map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2639 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2640 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2644 my($op, $cx, $name, $delim) = @_;
2645 my $kid = $op->first;
2646 my ($binop, $var, $re) = ("", "", "");
2647 if ($op->flags & OPf_STACKED) {
2649 $var = $self->deparse($kid, 20);
2650 $kid = $kid->sibling;
2653 $re = re_uninterp(escape_str($op->precomp));
2655 $re = $self->deparse($kid, 1);
2658 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2659 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2660 $flags .= "i" if $op->pmflags & PMf_FOLD;
2661 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2662 $flags .= "o" if $op->pmflags & PMf_KEEP;
2663 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2664 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2665 $flags = $matchwords{$flags} if $matchwords{$flags};
2666 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2670 $re = single_delim($name, $delim, $re);
2674 return $self->maybe_parens("$var =~ $re", $cx, 20);
2680 sub pp_match { matchop(@_, "m", "/") }
2681 sub pp_pushre { matchop(@_, "m", "/") }
2682 sub pp_qr { matchop(@_, "qr", "") }
2687 my($kid, @exprs, $ary, $expr);
2689 if ($ {$kid->pmreplroot}) {
2690 $ary = '@' . $self->gv_name($kid->pmreplroot);
2692 for (; !null($kid); $kid = $kid->sibling) {
2693 push @exprs, $self->deparse($kid, 6);
2695 $expr = "split(" . join(", ", @exprs) . ")";
2697 return $self->maybe_parens("$ary = $expr", $cx, 7);
2703 # oxime -- any of various compounds obtained chiefly by the action of
2704 # hydroxylamine on aldehydes and ketones and characterized by the
2705 # bivalent grouping C=NOH [Webster's Tenth]
2708 map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2709 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2710 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2711 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2716 my $kid = $op->first;
2717 my($binop, $var, $re, $repl) = ("", "", "", "");
2718 if ($op->flags & OPf_STACKED) {
2720 $var = $self->deparse($kid, 20);
2721 $kid = $kid->sibling;
2724 if (null($op->pmreplroot)) {
2725 $repl = $self->dq($kid);
2726 $kid = $kid->sibling;
2728 $repl = $op->pmreplroot->first; # skip substcont
2729 while ($repl->name eq "entereval") {
2730 $repl = $repl->first;
2733 if ($op->pmflags & PMf_EVAL) {
2734 $repl = $self->deparse($repl, 0);
2736 $repl = $self->dq($repl);
2740 $re = re_uninterp(escape_str($op->precomp));
2742 $re = $self->deparse($kid, 1);
2744 $flags .= "e" if $op->pmflags & PMf_EVAL;
2745 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2746 $flags .= "i" if $op->pmflags & PMf_FOLD;
2747 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2748 $flags .= "o" if $op->pmflags & PMf_KEEP;
2749 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2750 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2751 $flags = $substwords{$flags} if $substwords{$flags};
2753 return $self->maybe_parens("$var =~ s"
2754 . double_delim($re, $repl) . $flags,
2757 return "s". double_delim($re, $repl) . $flags;
2766 B::Deparse - Perl compiler backend to produce perl code
2770 B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-q>][B<,-l>][B<,-s>I<LETTERS>]
2775 B::Deparse is a backend module for the Perl compiler that generates
2776 perl source code, based on the internal compiled structure that perl
2777 itself creates after parsing a program. The output of B::Deparse won't
2778 be exactly the same as the original source, since perl doesn't keep
2779 track of comments or whitespace, and there isn't a one-to-one
2780 correspondence between perl's syntactical constructions and their
2781 compiled form, but it will often be close. When you use the B<-p>
2782 option, the output also includes parentheses even when they are not
2783 required by precedence, which can make it easy to see if perl is
2784 parsing your expressions the way you intended.
2786 Please note that this module is mainly new and untested code and is
2787 still under development, so it may change in the future.
2791 As with all compiler backend options, these must follow directly after
2792 the '-MO=Deparse', separated by a comma but not any white space.
2798 Add '#line' declarations to the output based on the line and file
2799 locations of the original code.
2803 Print extra parentheses. Without this option, B::Deparse includes
2804 parentheses in its output only when they are needed, based on the
2805 structure of your program. With B<-p>, it uses parentheses (almost)
2806 whenever they would be legal. This can be useful if you are used to
2807 LISP, or if you want to see how perl parses your input. If you say
2809 if ($var & 0x7f == 65) {print "Gimme an A!"}
2810 print ($which ? $a : $b), "\n";
2811 $name = $ENV{USER} or "Bob";
2813 C<B::Deparse,-p> will print
2816 print('Gimme an A!')
2818 (print(($which ? $a : $b)), '???');
2819 (($name = $ENV{'USER'}) or '???')
2821 which probably isn't what you intended (the C<'???'> is a sign that
2822 perl optimized away a constant value).
2826 Expand double-quoted strings into the corresponding combinations of
2827 concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
2830 print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
2834 print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
2835 . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
2837 Note that the expanded form represents the way perl handles such
2838 constructions internally -- this option actually turns off the reverse
2839 translation that B::Deparse usually does. On the other hand, note that
2840 C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
2841 of $y into a string before doing the assignment.
2843 =item B<-u>I<PACKAGE>
2845 Normally, B::Deparse deparses the main code of a program, all the subs
2846 called by the main program (and all the subs called by them,
2847 recursively), and any other subs in the main:: package. To include
2848 subs in other packages that aren't called directly, such as AUTOLOAD,
2849 DESTROY, other subs called automatically by perl, and methods (which
2850 aren't resolved to subs until runtime), use the B<-u> option. The
2851 argument to B<-u> is the name of a package, and should follow directly
2852 after the 'u'. Multiple B<-u> options may be given, separated by
2853 commas. Note that unlike some other backends, B::Deparse doesn't
2854 (yet) try to guess automatically when B<-u> is needed -- you must
2857 =item B<-s>I<LETTERS>
2859 Tweak the style of B::Deparse's output. The letters should follow
2860 directly after the 's', with no space or punctuation. The following
2861 options are available:
2867 Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2884 The default is not to cuddle.
2888 Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
2892 Use tabs for each 8 columns of indent. The default is to use only spaces.
2893 For instance, if the style options are B<-si4T>, a line that's indented
2894 3 times will be preceded by one tab and four spaces; if the options were
2895 B<-si8T>, the same line would be preceded by three tabs.
2897 =item B<v>I<STRING>B<.>
2899 Print I<STRING> for the value of a constant that can't be determined
2900 because it was optimized away (mnemonic: this happens when a constant
2901 is used in B<v>oid context). The end of the string is marked by a period.
2902 The string should be a valid perl expression, generally a constant.
2903 Note that unless it's a number, it probably needs to be quoted, and on
2904 a command line quotes need to be protected from the shell. Some
2905 conventional values include 0, 1, 42, '', 'foo', and
2906 'Useless use of constant omitted' (which may need to be
2907 B<-sv"'Useless use of constant omitted'.">
2908 or something similar depending on your shell). The default is '???'.
2909 If you're using B::Deparse on a module or other file that's require'd,
2910 you shouldn't use a value that evaluates to false, since the customary
2911 true constant at the end of a module will be in void context when the
2912 file is compiled as a main program.
2918 =head1 USING B::Deparse AS A MODULE
2923 $deparse = B::Deparse->new("-p", "-sC");
2924 $body = $deparse->coderef2text(\&func);
2925 eval "sub func $body"; # the inverse operation
2929 B::Deparse can also be used on a sub-by-sub basis from other perl
2934 $deparse = B::Deparse->new(OPTIONS)
2936 Create an object to store the state of a deparsing operation and any
2937 options. The options are the same as those that can be given on the
2938 command line (see L</OPTIONS>); options that are separated by commas
2939 after B<-MO=Deparse> should be given as separate strings. Some
2940 options, like B<-u>, don't make sense for a single subroutine, so
2945 $body = $deparse->coderef2text(\&func)
2946 $body = $deparse->coderef2text(sub ($$) { ... })
2948 Return source code for the body of a subroutine (a block, optionally
2949 preceded by a prototype in parens), given a reference to the
2950 sub. Because a subroutine can have no names, or more than one name,
2951 this method doesn't return a complete subroutine definition -- if you
2952 want to eval the result, you should prepend "sub subname ", or "sub "
2953 for an anonymous function constructor. Unless the sub was defined in
2954 the main:: package, the code will include a package declaration.
2958 See the 'to do' list at the beginning of the module file.
2962 Stephen McCamant <smccam@uclink4.berkeley.edu>, based on an earlier
2963 version by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with
2964 contributions from Gisle Aas, James Duncan, Albert Dvornik, Hugo van
2965 der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.