This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
applied a slightly tweaked version of suggested patch
[perl5.git] / ext / B / B / Deparse.pm
CommitLineData
6e90668e
SM
1# B::Deparse.pm
2# Copyright (c) 1998 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.
5
6# This is based on the module of the same name by Malcolm Beattie,
7# but essentially none of his code remains.
8
a798dbf2 9package B::Deparse;
6e90668e
SM
10use Carp 'cluck';
11use B qw(class main_root main_start main_cv svref_2object);
90be192f 12$VERSION = 0.55;
a798dbf2 13use strict;
a798dbf2 14
6e90668e
SM
15# Changes between 0.50 and 0.51:
16# - fixed nulled leave with live enter in sort { }
17# - fixed reference constants (\"str")
18# - handle empty programs gracefully
19# - handle infinte loops (for (;;) {}, while (1) {})
20# - differentiate between `for my $x ...' and `my $x; for $x ...'
21# - various minor cleanups
22# - moved globals into an object
23# - added `-u', like B::C
24# - package declarations using cop_stash
25# - subs, formats and code sorted by cop_seq
f6f9bdb7
SM
26# Changes between 0.51 and 0.52:
27# - added pp_threadsv (special variables under USE_THREADS)
28# - added documentation
9d2c6865
SM
29# Changes between 0.52 and 0.53
30# - many changes adding precedence contexts and associativity
31# - added `-p' and `-s' output style options
32# - various other minor fixes
d7f5b6da
SM
33# Changes between 0.53 and 0.54
34# - added support for new `for (1..100)' optimization,
35# thanks to Gisle Aas
90be192f
SM
36# Changes between 0.54 and 0.55
37# - added support for new qr// construct
38# - added support for new pp_regcreset OP
6e90668e
SM
39
40# Todo:
9d2c6865 41# - {} around variables in strings ("${var}letters")
90be192f 42# - left/right context
9d2c6865 43# - associativity of &&=, ||=, ?:
6e90668e
SM
44# - ',' => '=>' (auto-unquote?)
45# - break long lines ("\r" as discretionary break?)
46# - version using op_next instead of op_first/sibling?
47# - avoid string copies (pass arrays, one big join?)
48# - auto-apply `-u'?
9d2c6865
SM
49# - while{} with one-statement continue => for(; XXX; XXX) {}?
50# - -uPackage:: descend recursively?
51# - here-docs?
52# - <DATA>?
6e90668e
SM
53
54# Object fields (were globals):
55#
56# avoid_local:
57# (local($a), local($b)) and local($a, $b) have the same internal
58# representation but the short form looks better. We notice we can
59# use a large-scale local when checking the list, but need to prevent
60# individual locals too. This hash holds the addresses of OPs that
61# have already had their local-ness accounted for. The same thing
62# is done with my().
63#
64# curcv:
65# CV for current sub (or main program) being deparsed
66#
67# curstash:
68# name of the current package for deparsed code
69#
70# subs_todo:
71# array of [cop_seq, GV, is_format?] for subs and formats we still
72# want to deparse
73#
74# subs_done, forms_done:
75# keys are addresses of GVs for subs and formats we've already
76# deparsed (or at least put into subs_todo)
9d2c6865
SM
77#
78# parens: -p
79# cuddle: ` ' or `\n', depending on -sC
80
81# A little explanation of how precedence contexts and associativity
82# work:
83#
84# deparse() calls each per-op subroutine with an argument $cx (short
85# for context, but not the same as the cx* in the perl core), which is
86# a number describing the op's parents in terms of precedence, whether
87# they're inside and expression or at statement level, etc. (see
88# chart below). When ops with children call deparse on them, they pass
89# along their precedence. Fractional values are used to implement
90# associativity (`($x + $y) + $z' => `$x + $y + $y') and related
91# parentheses hacks. The major disadvantage of this scheme is that
92# it doesn't know about right sides and left sides, so say if you
93# assign a listop to a variable, it can't tell it's allowed to leave
94# the parens off the listop.
95
96# Precedences:
97# 26 [TODO] inside interpolation context ("")
98# 25 left terms and list operators (leftward)
99# 24 left ->
100# 23 nonassoc ++ --
101# 22 right **
102# 21 right ! ~ \ and unary + and -
103# 20 left =~ !~
104# 19 left * / % x
105# 18 left + - .
106# 17 left << >>
107# 16 nonassoc named unary operators
108# 15 nonassoc < > <= >= lt gt le ge
109# 14 nonassoc == != <=> eq ne cmp
110# 13 left &
111# 12 left | ^
112# 11 left &&
113# 10 left ||
114# 9 nonassoc .. ...
115# 8 right ?:
116# 7 right = += -= *= etc.
117# 6 left , =>
118# 5 nonassoc list operators (rightward)
119# 4 right not
120# 3 left and
121# 2 left or xor
122# 1 statement modifiers
123# 0 statement level
124
125# Nonprinting characters with special meaning:
126# \cS - steal parens (see maybe_parens_unop)
127# \n - newline and indent
128# \t - increase indent
129# \b - decrease indent (`outdent')
130# \cK - kill following semicolon, if any
6e90668e
SM
131
132sub null {
133 my $op = shift;
134 return class($op) eq "NULL";
135}
136
137sub todo {
138 my $self = shift;
139 my($gv, $cv, $is_form) = @_;
140 my $seq;
141 if (!null($cv->START) and is_state($cv->START)) {
142 $seq = $cv->START->cop_seq;
143 } else {
144 $seq = 0;
145 }
146 push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
147}
148
149sub next_todo {
150 my $self = shift;
151 my $ent = shift @{$self->{'subs_todo'}};
152 my $name = $self->gv_name($ent->[1]);
153 if ($ent->[2]) {
154 return "format $name =\n"
155 . $self->deparse_format($ent->[1]->FORM). "\n";
156 } else {
157 return "sub $name " .
158 $self->deparse_sub($ent->[1]->CV);
159 }
160}
161
162sub OPf_KIDS () { 4 }
163
164sub walk_tree {
165 my($op, $sub) = @_;
166 $sub->($op);
167 if ($op->flags & OPf_KIDS) {
168 my $kid;
169 for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
170 walk_tree($kid, $sub);
171 }
172 }
173}
174
175sub walk_sub {
176 my $self = shift;
177 my $cv = shift;
178 my $op = $cv->ROOT;
179 $op = shift if null $op;
180 return if !$op or null $op;
181 walk_tree($op, sub {
182 my $op = shift;
183 if ($op->ppaddr eq "pp_gv") {
184 if ($op->next->ppaddr eq "pp_entersub") {
185 next if $self->{'subs_done'}{$ {$op->gv}}++;
186 next if class($op->gv->CV) eq "SPECIAL";
187 $self->todo($op->gv, $op->gv->CV, 0);
188 $self->walk_sub($op->gv->CV);
189 } elsif ($op->next->ppaddr eq "pp_enterwrite"
190 or ($op->next->ppaddr eq "pp_rv2gv"
191 and $op->next->next->ppaddr eq "pp_enterwrite")) {
192 next if $self->{'forms_done'}{$ {$op->gv}}++;
193 next if class($op->gv->FORM) eq "SPECIAL";
194 $self->todo($op->gv, $op->gv->FORM, 1);
195 $self->walk_sub($op->gv->FORM);
196 }
197 }
198 });
199}
200
201sub stash_subs {
202 my $self = shift;
203 my $pack = shift;
204 my(%stash, @ret);
205 { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
206 my($key, $val);
207 while (($key, $val) = each %stash) {
208 next unless class($val) eq "GV";
209 if (class($val->CV) ne "SPECIAL") {
210 next if $self->{'subs_done'}{$$val}++;
211 $self->todo($val, $val->CV, 0);
212 $self->walk_sub($val->CV);
213 }
214 if (class($val->FORM) ne "SPECIAL") {
215 next if $self->{'forms_done'}{$$val}++;
216 $self->todo($val, $val->FORM, 1);
217 $self->walk_sub($val->FORM);
218 }
219 }
220}
a798dbf2 221
9d2c6865
SM
222sub style_opts {
223 my $self = shift;
224 my $opts = shift;
225 my $opt;
226 while (length($opt = substr($opts, 0, 1))) {
227 if ($opt eq "C") {
228 $self->{'cuddle'} = " ";
229 }
230 $opts = substr($opts, 1);
231 }
232}
233
a798dbf2 234sub compile {
6e90668e
SM
235 my(@args) = @_;
236 return sub {
237 my $self = bless {};
238 my $arg;
239 $self->{'subs_todo'} = [];
240 $self->stash_subs("main");
241 $self->{'curcv'} = main_cv;
242 $self->{'curstash'} = "main";
9d2c6865 243 $self->{'cuddle'} = "\n";
6e90668e
SM
244 while ($arg = shift @args) {
245 if (substr($arg, 0, 2) eq "-u") {
246 $self->stash_subs(substr($arg, 2));
9d2c6865
SM
247 } elsif ($arg eq "-p") {
248 $self->{'parens'} = 1;
249 } elsif (substr($arg, 0, 2) eq "-s") {
250 $self->style_opts(substr $arg, 2);
6e90668e
SM
251 }
252 }
253 $self->walk_sub(main_cv, main_start);
254 @{$self->{'subs_todo'}} =
255 sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
9d2c6865 256 print indent($self->deparse(main_root, 0)), "\n" unless null main_root;
6e90668e
SM
257 my @text;
258 while (scalar(@{$self->{'subs_todo'}})) {
259 push @text, $self->next_todo;
260 }
261 print indent(join("", @text)), "\n" if @text;
a798dbf2 262 }
a798dbf2
MB
263}
264
6e90668e
SM
265sub deparse {
266 my $self = shift;
9d2c6865
SM
267 my($op, $cx) = @_;
268# cluck if class($op) eq "NULL";
6e90668e 269 my $meth = $op->ppaddr;
9d2c6865 270 return $self->$meth($op, $cx);
a798dbf2
MB
271}
272
6e90668e
SM
273sub indent {
274 my $txt = shift;
275 my @lines = split(/\n/, $txt);
276 my $leader = "";
277 my $line;
278 for $line (@lines) {
279 if (substr($line, 0, 1) eq "\t") {
280 $leader = $leader . " ";
281 $line = substr($line, 1);
282 } elsif (substr($line, 0, 1) eq "\b") {
283 $leader = substr($leader, 0, length($leader) - 4);
284 $line = substr($line, 1);
285 }
9d2c6865 286 $line =~ s/\cK;?//g;
6e90668e
SM
287 $line = $leader . $line;
288 }
289 return join("\n", @lines);
290}
291
292sub SVf_POK () {0x40000}
293
294sub deparse_sub {
295 my $self = shift;
296 my $cv = shift;
297 my $proto = "";
298 if ($cv->FLAGS & SVf_POK) {
299 $proto = "(". $cv->PV . ") ";
300 }
301 local($self->{'curcv'}) = $cv;
302 local($self->{'curstash'}) = $self->{'curstash'};
303 if (not null $cv->ROOT) {
304 # skip leavesub
305 return $proto . "{\n\t" .
9d2c6865 306 $self->deparse($cv->ROOT->first, 0) . "\n\b}\n";
6e90668e
SM
307 } else { # XSUB?
308 return $proto . "{}\n";
309 }
310}
311
312sub deparse_format {
313 my $self = shift;
314 my $form = shift;
315 my @text;
316 local($self->{'curcv'}) = $form;
317 local($self->{'curstash'}) = $self->{'curstash'};
318 my $op = $form->ROOT;
319 my $kid;
320 $op = $op->first->first; # skip leavewrite, lineseq
321 while (not null $op) {
322 $op = $op->sibling; # skip nextstate
323 my @exprs;
324 $kid = $op->first->sibling; # skip pushmark
325 push @text, $kid->sv->PV;
326 $kid = $kid->sibling;
327 for (; not null $kid; $kid = $kid->sibling) {
9d2c6865 328 push @exprs, $self->deparse($kid, 0);
6e90668e
SM
329 }
330 push @text, join(", ", @exprs)."\n" if @exprs;
331 $op = $op->sibling;
332 }
333 return join("", @text) . ".";
334}
335
336# the aassign in-common check messes up SvCUR (always setting it
337# to a value >= 100), but it's probably safe to assume there
338# won't be any NULs in the names of my() variables. (with
339# stash variables, I wouldn't be so sure)
340sub padname_fix {
341 my $str = shift;
342 $str = substr($str, 0, index($str, "\0")) if index($str, "\0") != -1;
343 return $str;
344}
345
346sub is_scope {
a798dbf2 347 my $op = shift;
6e90668e 348 return $op->ppaddr eq "pp_leave" || $op->ppaddr eq "pp_scope"
9d2c6865 349 || $op->ppaddr eq "pp_lineseq"
6e90668e
SM
350 || ($op->ppaddr eq "pp_null" && class($op) eq "UNOP"
351 && (is_scope($op->first) || $op->first->ppaddr eq "pp_enter"));
352}
353
354sub is_state {
355 my $name = $_[0]->ppaddr;
356 return $name eq "pp_nextstate" || $name eq "pp_dbstate";
357}
358
359sub is_miniwhile { # check for one-line loop (`foo() while $y--')
360 my $op = shift;
361 return (!null($op) and null($op->sibling)
362 and $op->ppaddr eq "pp_null" and class($op) eq "UNOP"
363 and (($op->first->ppaddr =~ /^pp_(and|or)$/
364 and $op->first->first->sibling->ppaddr eq "pp_lineseq")
365 or ($op->first->ppaddr eq "pp_lineseq"
366 and not null $op->first->first->sibling
367 and $op->first->first->sibling->ppaddr eq "pp_unstack")
368 ));
369}
370
371sub is_scalar {
372 my $op = shift;
373 return ($op->ppaddr eq "pp_rv2sv" or
374 $op->ppaddr eq "pp_padsv" or
375 $op->ppaddr eq "pp_gv" or # only in array/hash constructs
376 !null($op->first) && $op->first->ppaddr eq "pp_gvsv");
377}
378
9d2c6865
SM
379sub maybe_parens {
380 my $self = shift;
381 my($text, $cx, $prec) = @_;
382 if ($prec < $cx # unary ops nest just fine
383 or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
384 or $self->{'parens'})
385 {
386 $text = "($text)";
387 # In a unop, let parent reuse our parens; see maybe_parens_unop
388 $text = "\cS" . $text if $cx == 16;
389 return $text;
390 } else {
391 return $text;
392 }
393}
394
395# same as above, but get around the `if it looks like a function' rule
396sub maybe_parens_unop {
397 my $self = shift;
398 my($name, $kid, $cx) = @_;
399 if ($cx > 16 or $self->{'parens'}) {
400 return "$name(" . $self->deparse($kid, 1) . ")";
401 } else {
402 $kid = $self->deparse($kid, 16);
403 if (substr($kid, 0, 1) eq "\cS") {
404 # use kid's parens
405 return $name . substr($kid, 1);
406 } elsif (substr($kid, 0, 1) eq "(") {
407 # avoid looks-like-a-function trap with extra parens
408 # (`+' can lead to ambiguities)
409 return "$name(" . $kid . ")";
410 } else {
411 return "$name $kid";
412 }
413 }
414}
415
416sub maybe_parens_func {
417 my $self = shift;
418 my($func, $text, $cx, $prec) = @_;
419 if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
420 return "$func($text)";
421 } else {
422 return "$func $text";
423 }
424}
425
6e90668e
SM
426sub OPp_LVAL_INTRO () { 128 }
427
428sub maybe_local {
429 my $self = shift;
9d2c6865 430 my($op, $cx, $text) = @_;
6e90668e 431 if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
9d2c6865 432 return $self->maybe_parens_func("local", $text, $cx, 16);
6e90668e
SM
433 } else {
434 return $text;
a798dbf2 435 }
a798dbf2
MB
436}
437
6e90668e
SM
438sub padname_sv {
439 my $self = shift;
440 my $targ = shift;
441 return (($self->{'curcv'}->PADLIST->ARRAY)[0]->ARRAY)[$targ];
442}
443
444sub maybe_my {
445 my $self = shift;
9d2c6865 446 my($op, $cx, $text) = @_;
6e90668e 447 if ($op->private & OPp_LVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
9d2c6865 448 return $self->maybe_parens_func("my", $text, $cx, 16);
6e90668e
SM
449 } else {
450 return $text;
451 }
452}
453
9d2c6865
SM
454# The following OPs don't have functions:
455
456# pp_padany -- does not exist after parsing
457# pp_rcatline -- does not exist
458
459sub pp_enter { # see also leave
460 cluck "unexpected OP_ENTER";
461 return "XXX";
462}
463
464sub pp_pushmark { # see also list
465 cluck "unexpected OP_PUSHMARK";
466 return "XXX";
467}
468
469sub pp_leavesub { # see also deparse_sub
470 cluck "unexpected OP_LEAVESUB";
471 return "XXX";
472}
473
474sub pp_leavewrite { # see also deparse_format
475 cluck "unexpected OP_LEAVEWRITE";
476 return "XXX";
477}
478
479sub pp_method { # see also entersub
480 cluck "unexpected OP_METHOD";
481 return "XXX";
482}
483
484sub pp_regcmaybe { # see also regcomp
485 cluck "unexpected OP_REGCMAYBE";
486 return "XXX";
487}
488
90be192f
SM
489sub pp_regcreset { # see also regcomp
490 cluck "unexpected OP_REGCRESET";
491 return "XXX";
492}
493
9d2c6865
SM
494sub pp_substcont { # see also subst
495 cluck "unexpected OP_SUBSTCONT";
496 return "XXX";
497}
498
499sub pp_grepstart { # see also grepwhile
500 cluck "unexpected OP_GREPSTART";
501 return "XXX";
502}
503
504sub pp_mapstart { # see also mapwhile
505 cluck "unexpected OP_MAPSTART";
506 return "XXX";
507}
508
509sub pp_flip { # see also flop
510 cluck "unexpected OP_FLIP";
511 return "XXX";
512}
513
514sub pp_iter { # see also leaveloop
515 cluck "unexpected OP_ITER";
516 return "XXX";
517}
518
519sub pp_enteriter { # see also leaveloop
520 cluck "unexpected OP_ENTERITER";
521 return "XXX";
522}
523
524sub pp_enterloop { # see also leaveloop
525 cluck "unexpected OP_ENTERLOOP";
526 return "XXX";
527}
528
529sub pp_leaveeval { # see also entereval
530 cluck "unexpected OP_LEAVEEVAL";
531 return "XXX";
532}
533
534sub pp_entertry { # see also leavetry
535 cluck "unexpected OP_ENTERTRY";
536 return "XXX";
537}
6e90668e 538
9d2c6865 539# leave and scope/lineseq should probably share code
a798dbf2 540sub pp_leave {
6e90668e 541 my $self = shift;
9d2c6865 542 my($op, $cx) = @_;
6e90668e
SM
543 my ($kid, $expr);
544 my @exprs;
545 local($self->{'curstash'}) = $self->{'curstash'};
546 $kid = $op->first->sibling; # skip enter
547 if (is_miniwhile($kid)) {
548 my $top = $kid->first;
549 my $name = $top->ppaddr;
550 if ($name eq "pp_and") {
551 $name = "while";
552 } elsif ($name eq "pp_or") {
553 $name = "until";
554 } else { # no conditional -> while 1 or until 0
9d2c6865 555 return $self->deparse($top->first, 1) . " while 1";
6e90668e
SM
556 }
557 my $cond = $top->first;
9d2c6865
SM
558 my $body = $cond->sibling->first; # skip lineseq
559 $cond = $self->deparse($cond, 1);
560 $body = $self->deparse($body, 1);
6e90668e
SM
561 return "$body $name $cond";
562 }
563 for (; !null($kid); $kid = $kid->sibling) {
564 $expr = "";
565 if (is_state $kid) {
9d2c6865 566 $expr = $self->deparse($kid, 0);
6e90668e
SM
567 $kid = $kid->sibling;
568 last if null $kid;
569 }
9d2c6865 570 $expr .= $self->deparse($kid, 0);
6e90668e
SM
571 push @exprs, $expr if $expr;
572 }
9d2c6865
SM
573 if ($cx > 0) { # inside an expression
574 return "do { " . join(";\n", @exprs) . " }";
575 } else {
576 return join(";\n", @exprs);
577 }
6e90668e
SM
578}
579
580sub pp_scope {
581 my $self = shift;
9d2c6865 582 my($op, $cx) = @_;
6e90668e
SM
583 my ($kid, $expr);
584 my @exprs;
585 for ($kid = $op->first; !null($kid); $kid = $kid->sibling) {
586 $expr = "";
587 if (is_state $kid) {
9d2c6865 588 $expr = $self->deparse($kid, 0);
6e90668e
SM
589 $kid = $kid->sibling;
590 last if null $kid;
591 }
9d2c6865 592 $expr .= $self->deparse($kid, 0);
6e90668e
SM
593 push @exprs, $expr if $expr;
594 }
9d2c6865
SM
595 if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
596 return "do { " . join(";\n", @exprs) . " }";
597 } else {
598 return join(";\n", @exprs);
6e90668e 599 }
6e90668e
SM
600}
601
9d2c6865
SM
602sub pp_lineseq { pp_scope(@_) }
603
6e90668e
SM
604# The BEGIN {} is used here because otherwise this code isn't executed
605# when you run B::Deparse on itself.
606my %globalnames;
607BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
608 "ENV", "ARGV", "ARGVOUT", "_"); }
609
610sub gv_name {
611 my $self = shift;
612 my $gv = shift;
613 my $stash = $gv->STASH->NAME;
614 my $name = $gv->NAME;
9d2c6865
SM
615 if ($stash eq $self->{'curstash'} or $globalnames{$name}
616 or $name =~ /^[^A-Za-z_]/)
617 {
6e90668e
SM
618 $stash = "";
619 } else {
620 $stash = $stash . "::";
a798dbf2 621 }
6e90668e
SM
622 if ($name =~ /^([\cA-\cZ])$/) {
623 $name = "^" . chr(64 + ord($1));
624 }
625 return $stash . $name;
a798dbf2
MB
626}
627
6e90668e
SM
628# Notice how subs and formats are inserted between statements here
629sub pp_nextstate {
630 my $self = shift;
9d2c6865 631 my($op, $cx) = @_;
6e90668e
SM
632 my @text;
633 @text = $op->label . ": " if $op->label;
634 my $seq = $op->cop_seq;
635 while (scalar(@{$self->{'subs_todo'}})
636 and $seq > $self->{'subs_todo'}[0][0]) {
637 push @text, $self->next_todo;
638 }
639 my $stash = $op->stash->NAME;
640 if ($stash ne $self->{'curstash'}) {
641 push @text, "package $stash;\n";
642 $self->{'curstash'} = $stash;
643 }
644 return join("", @text);
645}
646
647sub pp_dbstate { pp_nextstate(@_) }
648
649sub pp_unstack { return "" } # see also leaveloop
650
651sub baseop {
652 my $self = shift;
9d2c6865 653 my($op, $cx, $name) = @_;
6e90668e
SM
654 return $name;
655}
656
657sub pp_stub { baseop(@_, "()") }
658sub pp_wantarray { baseop(@_, "wantarray") }
659sub pp_fork { baseop(@_, "fork") }
660sub pp_wait { baseop(@_, "wait") }
661sub pp_getppid { baseop(@_, "getppid") }
662sub pp_time { baseop(@_, "time") }
663sub pp_tms { baseop(@_, "times") }
664sub pp_ghostent { baseop(@_, "gethostent") }
665sub pp_gnetent { baseop(@_, "getnetent") }
666sub pp_gprotoent { baseop(@_, "getprotoent") }
667sub pp_gservent { baseop(@_, "getservent") }
668sub pp_ehostent { baseop(@_, "endhostent") }
669sub pp_enetent { baseop(@_, "endnetent") }
670sub pp_eprotoent { baseop(@_, "endprotoent") }
671sub pp_eservent { baseop(@_, "endservent") }
672sub pp_gpwent { baseop(@_, "getpwent") }
673sub pp_spwent { baseop(@_, "setpwent") }
674sub pp_epwent { baseop(@_, "endpwent") }
675sub pp_ggrent { baseop(@_, "getgrent") }
676sub pp_sgrent { baseop(@_, "setgrent") }
677sub pp_egrent { baseop(@_, "endgrent") }
678sub pp_getlogin { baseop(@_, "getlogin") }
679
680sub POSTFIX () { 1 }
681
9d2c6865
SM
682# I couldn't think of a good short name, but this is the category of
683# symbolic unary operators with interesting precedence
684
685sub pfixop {
686 my $self = shift;
687 my($op, $cx, $name, $prec, $flags) = (@_, 0);
688 my $kid = $op->first;
689 $kid = $self->deparse($kid, $prec);
690 return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
691 $cx, $prec);
692}
693
694sub pp_preinc { pfixop(@_, "++", 23) }
695sub pp_predec { pfixop(@_, "--", 23) }
696sub pp_postinc { pfixop(@_, "++", 23, POSTFIX) }
697sub pp_postdec { pfixop(@_, "--", 23, POSTFIX) }
698sub pp_i_preinc { pfixop(@_, "++", 23) }
699sub pp_i_predec { pfixop(@_, "--", 23) }
700sub pp_i_postinc { pfixop(@_, "++", 23, POSTFIX) }
701sub pp_i_postdec { pfixop(@_, "--", 23, POSTFIX) }
702sub pp_complement { pfixop(@_, "~", 21) }
703
704sub pp_negate {
705 my $self = shift;
706 my($op, $cx) = @_;
707 if ($op->first->ppaddr =~ /^pp_(i_)?negate$/) {
708 # avoid --$x
709 $self->pfixop($op, $cx, "-", 21.5);
710 } else {
711 $self->pfixop($op, $cx, "-", 21);
712 }
713}
714sub pp_i_negate { pp_negate(@_) }
715
716sub pp_not {
717 my $self = shift;
718 my($op, $cx) = @_;
719 if ($cx <= 4) {
720 $self->pfixop($op, $cx, "not ", 4);
721 } else {
722 $self->pfixop($op, $cx, "!", 21);
723 }
724}
725
6e90668e
SM
726sub OPf_SPECIAL () { 128 }
727
728sub unop {
729 my $self = shift;
9d2c6865 730 my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
6e90668e 731 my $kid;
9d2c6865 732 if ($op->flags & OPf_KIDS) {
6e90668e 733 $kid = $op->first;
9d2c6865 734 return $self->maybe_parens_unop($name, $kid, $cx);
6e90668e 735 } else {
9d2c6865 736 return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
6e90668e 737 }
6e90668e
SM
738}
739
6e90668e
SM
740sub pp_chop { unop(@_, "chop") }
741sub pp_chomp { unop(@_, "chomp") }
742sub pp_schop { unop(@_, "chop") }
743sub pp_schomp { unop(@_, "chomp") }
744sub pp_defined { unop(@_, "defined") }
745sub pp_undef { unop(@_, "undef") }
746sub pp_study { unop(@_, "study") }
6e90668e
SM
747sub pp_ref { unop(@_, "ref") }
748sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
749
750sub pp_sin { unop(@_, "sin") }
751sub pp_cos { unop(@_, "cos") }
752sub pp_rand { unop(@_, "rand") }
753sub pp_srand { unop(@_, "srand") }
754sub pp_exp { unop(@_, "exp") }
755sub pp_log { unop(@_, "log") }
756sub pp_sqrt { unop(@_, "sqrt") }
757sub pp_int { unop(@_, "int") }
758sub pp_hex { unop(@_, "hex") }
759sub pp_oct { unop(@_, "oct") }
760sub pp_abs { unop(@_, "abs") }
761
762sub pp_length { unop(@_, "length") }
763sub pp_ord { unop(@_, "ord") }
764sub pp_chr { unop(@_, "chr") }
765sub pp_ucfirst { unop(@_, "ucfirst") }
766sub pp_lcfirst { unop(@_, "lcfirst") }
767sub pp_uc { unop(@_, "uc") }
768sub pp_lc { unop(@_, "lc") }
769sub pp_quotemeta { unop(@_, "quotemeta") }
770
771sub pp_each { unop(@_, "each") }
772sub pp_values { unop(@_, "values") }
773sub pp_keys { unop(@_, "keys") }
774sub pp_pop { unop(@_, "pop") }
775sub pp_shift { unop(@_, "shift") }
776
777sub pp_caller { unop(@_, "caller") }
778sub pp_reset { unop(@_, "reset") }
779sub pp_exit { unop(@_, "exit") }
780sub pp_prototype { unop(@_, "prototype") }
781
782sub pp_close { unop(@_, "close") }
783sub pp_fileno { unop(@_, "fileno") }
784sub pp_umask { unop(@_, "umask") }
785sub pp_binmode { unop(@_, "binmode") }
786sub pp_untie { unop(@_, "untie") }
787sub pp_tied { unop(@_, "tied") }
788sub pp_dbmclose { unop(@_, "dbmclose") }
789sub pp_getc { unop(@_, "getc") }
790sub pp_eof { unop(@_, "eof") }
791sub pp_tell { unop(@_, "tell") }
792sub pp_getsockname { unop(@_, "getsockname") }
793sub pp_getpeername { unop(@_, "getpeername") }
794
795sub pp_chdir { unop(@_, "chdir") }
796sub pp_chroot { unop(@_, "chroot") }
797sub pp_readlink { unop(@_, "readlink") }
798sub pp_rmdir { unop(@_, "rmdir") }
799sub pp_readdir { unop(@_, "readdir") }
800sub pp_telldir { unop(@_, "telldir") }
801sub pp_rewinddir { unop(@_, "rewinddir") }
802sub pp_closedir { unop(@_, "closedir") }
803sub pp_getpgrp { unop(@_, "getpgrp") }
804sub pp_localtime { unop(@_, "localtime") }
805sub pp_gmtime { unop(@_, "gmtime") }
806sub pp_alarm { unop(@_, "alarm") }
807sub pp_sleep { unop(@_, "sleep") }
808
809sub pp_dofile { unop(@_, "do") }
810sub pp_entereval { unop(@_, "eval") }
811
812sub pp_ghbyname { unop(@_, "gethostbyname") }
813sub pp_gnbyname { unop(@_, "getnetbyname") }
814sub pp_gpbyname { unop(@_, "getprotobyname") }
815sub pp_shostent { unop(@_, "sethostent") }
816sub pp_snetent { unop(@_, "setnetent") }
817sub pp_sprotoent { unop(@_, "setprotoent") }
818sub pp_sservent { unop(@_, "setservent") }
819sub pp_gpwnam { unop(@_, "getpwnam") }
820sub pp_gpwuid { unop(@_, "getpwuid") }
821sub pp_ggrnam { unop(@_, "getgrnam") }
822sub pp_ggrgid { unop(@_, "getgrgid") }
823
824sub pp_lock { unop(@_, "lock") }
825
826sub pp_exists {
827 my $self = shift;
9d2c6865
SM
828 my($op, $cx) = @_;
829 return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
830 $cx, 16);
6e90668e
SM
831}
832
833sub OPpSLICE () { 64 }
834
835sub pp_delete {
836 my $self = shift;
9d2c6865 837 my($op, $cx) = @_;
6e90668e
SM
838 my $arg;
839 if ($op->private & OPpSLICE) {
9d2c6865
SM
840 return $self->maybe_parens_func("delete",
841 $self->pp_hslice($op->first, 16),
842 $cx, 16);
6e90668e 843 } else {
9d2c6865
SM
844 return $self->maybe_parens_func("delete",
845 $self->pp_helem($op->first, 16),
846 $cx, 16);
6e90668e 847 }
6e90668e
SM
848}
849
850sub OPp_CONST_BARE () { 64 }
851
852sub pp_require {
853 my $self = shift;
9d2c6865 854 my($op, $cx) = @_;
6e90668e
SM
855 if (class($op) eq "UNOP" and $op->first->ppaddr eq "pp_const"
856 and $op->first->private & OPp_CONST_BARE)
857 {
858 my $name = $op->first->sv->PV;
859 $name =~ s[/][::]g;
860 $name =~ s/\.pm//g;
861 return "require($name)";
862 } else {
9d2c6865 863 $self->unop($op, $cx, "require");
6e90668e
SM
864 }
865}
866
9d2c6865
SM
867sub pp_scalar {
868 my $self = shift;
869 my($op, $cv) = @_;
870 my $kid = $op->first;
871 if (not null $kid->sibling) {
872 # XXX Was a here-doc
873 return $self->dquote($op);
874 }
875 $self->unop(@_, "scalar");
876}
877
878
6e90668e
SM
879sub padval {
880 my $self = shift;
881 my $targ = shift;
882 return (($self->{'curcv'}->PADLIST->ARRAY)[1]->ARRAY)[$targ];
883}
884
9d2c6865
SM
885sub OPf_REF () { 16 }
886
6e90668e
SM
887sub pp_refgen {
888 my $self = shift;
9d2c6865 889 my($op, $cx) = @_;
6e90668e
SM
890 my $kid = $op->first;
891 if ($kid->ppaddr eq "pp_null") {
892 $kid = $kid->first;
893 if ($kid->ppaddr eq "pp_anonlist" || $kid->ppaddr eq "pp_anonhash") {
894 my($pre, $post) = @{{"pp_anonlist" => ["[","]"],
895 "pp_anonhash" => ["{","}"]}->{$kid->ppaddr}};
896 my($expr, @exprs);
897 $kid = $kid->first->sibling; # skip pushmark
898 for (; !null($kid); $kid = $kid->sibling) {
9d2c6865 899 $expr = $self->deparse($kid, 6);
6e90668e
SM
900 push @exprs, $expr;
901 }
902 return $pre . join(", ", @exprs) . $post;
903 } elsif (!null($kid->sibling) and
904 $kid->sibling->ppaddr eq "pp_anoncode") {
905 return "sub " .
906 $self->deparse_sub($self->padval($kid->sibling->targ));
9d2c6865
SM
907 } elsif ($kid->ppaddr eq "pp_pushmark"
908 and $kid->sibling->ppaddr =~ /^pp_(pad|rv2)[ah]v$/
909 and not $kid->sibling->flags & OPf_REF) {
910 # The @a in \(@a) isn't in ref context, but only when the
911 # parens are there.
912 return "\\(" . $self->deparse($kid->sibling, 1) . ")";
6e90668e
SM
913 }
914 }
9d2c6865 915 $self->pfixop($op, $cx, "\\", 20);
6e90668e
SM
916}
917
918sub pp_srefgen { pp_refgen(@_) }
919
920sub pp_readline {
921 my $self = shift;
9d2c6865 922 my($op, $cx) = @_;
6e90668e
SM
923 my $kid = $op->first;
924 $kid = $kid->first if $kid->ppaddr eq "pp_rv2gv"; # <$fh>
925 if ($kid->ppaddr eq "pp_rv2gv") {
926 $kid = $kid->first;
927 }
9d2c6865 928 return "<" . $self->deparse($kid, 1) . ">";
6e90668e
SM
929}
930
931sub loopex {
932 my $self = shift;
9d2c6865 933 my ($op, $cx, $name) = @_;
6e90668e 934 if (class($op) eq "PVOP") {
9d2c6865
SM
935 return "$name " . $op->pv;
936 } elsif (class($op) eq "OP") {
937 return $name;
6e90668e 938 } elsif (class($op) eq "UNOP") {
9d2c6865
SM
939 # Note -- loop exits are actually exempt from the
940 # looks-like-a-func rule, but a few extra parens won't hurt
941 return $self->maybe_parens_unop($name, $op->first, $cx);
6e90668e 942 }
6e90668e
SM
943}
944
945sub pp_last { loopex(@_, "last") }
946sub pp_next { loopex(@_, "next") }
947sub pp_redo { loopex(@_, "redo") }
948sub pp_goto { loopex(@_, "goto") }
949sub pp_dump { loopex(@_, "dump") }
950
951sub ftst {
952 my $self = shift;
9d2c6865 953 my($op, $cx, $name) = @_;
6e90668e 954 if (class($op) eq "UNOP") {
9d2c6865
SM
955 # Genuine `-X' filetests are exempt from the LLAFR, but not
956 # l?stat(); for the sake of clarity, give'em all parens
957 return $self->maybe_parens_unop($name, $op->first, $cx);
6e90668e 958 } elsif (class($op) eq "GVOP") {
9d2c6865 959 return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
6e90668e 960 } else { # I don't think baseop filetests ever survive ck_ftst, but...
9d2c6865 961 return $name;
6e90668e 962 }
6e90668e
SM
963}
964
965sub pp_lstat { ftst(@_, "lstat") }
966sub pp_stat { ftst(@_, "stat") }
967sub pp_ftrread { ftst(@_, "-R") }
968sub pp_ftrwrite { ftst(@_, "-W") }
969sub pp_ftrexec { ftst(@_, "-X") }
970sub pp_fteread { ftst(@_, "-r") }
971sub pp_ftewrite { ftst(@_, "-r") }
972sub pp_fteexec { ftst(@_, "-r") }
973sub pp_ftis { ftst(@_, "-e") }
974sub pp_fteowned { ftst(@_, "-O") }
975sub pp_ftrowned { ftst(@_, "-o") }
976sub pp_ftzero { ftst(@_, "-z") }
977sub pp_ftsize { ftst(@_, "-s") }
978sub pp_ftmtime { ftst(@_, "-M") }
979sub pp_ftatime { ftst(@_, "-A") }
980sub pp_ftctime { ftst(@_, "-C") }
981sub pp_ftsock { ftst(@_, "-S") }
982sub pp_ftchr { ftst(@_, "-c") }
983sub pp_ftblk { ftst(@_, "-b") }
984sub pp_ftfile { ftst(@_, "-f") }
985sub pp_ftdir { ftst(@_, "-d") }
986sub pp_ftpipe { ftst(@_, "-p") }
987sub pp_ftlink { ftst(@_, "-l") }
988sub pp_ftsuid { ftst(@_, "-u") }
989sub pp_ftsgid { ftst(@_, "-g") }
990sub pp_ftsvtx { ftst(@_, "-k") }
991sub pp_fttty { ftst(@_, "-t") }
992sub pp_fttext { ftst(@_, "-T") }
993sub pp_ftbinary { ftst(@_, "-B") }
994
a798dbf2 995sub SWAP_CHILDREN () { 1 }
6e90668e
SM
996sub ASSIGN () { 2 } # has OP= variant
997
998sub OPf_STACKED () { 64 }
a798dbf2 999
9d2c6865
SM
1000my(%left, %right);
1001
1002sub assoc_class {
1003 my $op = shift;
1004 my $name = $op->ppaddr;
1005 if ($name eq "pp_concat" and $op->first->ppaddr eq "pp_concat") {
1006 # avoid spurious `=' -- see comment in pp_concat
1007 return "pp_concat";
1008 }
1009 if ($name eq "pp_null" and class($op) eq "UNOP"
1010 and $op->first->ppaddr =~ /^pp_(and|x?or)$/
1011 and null $op->first->sibling)
1012 {
1013 # Like all conditional constructs, OP_ANDs and OP_ORs are topped
1014 # with a null that's used as the common end point of the two
1015 # flows of control. For precedence purposes, ignore it.
1016 # (COND_EXPRs have these too, but we don't bother with
1017 # their associativity).
1018 return assoc_class($op->first);
1019 }
1020 return $name . ($op->flags & OPf_STACKED ? "=" : "");
1021}
1022
1023# Left associative operators, like `+', for which
1024# $a + $b + $c is equivalent to ($a + $b) + $c
1025
1026BEGIN {
1027 %left = ('pp_multiply' => 19, 'pp_i_multiply' => 19,
1028 'pp_divide' => 19, 'pp_i_divide' => 19,
1029 'pp_modulo' => 19, 'pp_i_modulo' => 19,
1030 'pp_repeat' => 19,
1031 'pp_add' => 18, 'pp_i_add' => 18,
1032 'pp_subtract' => 18, 'pp_i_subtract' => 18,
1033 'pp_concat' => 18,
1034 'pp_left_shift' => 17, 'pp_right_shift' => 17,
1035 'pp_bit_and' => 13,
1036 'pp_bit_or' => 12, 'pp_bit_xor' => 12,
1037 'pp_and' => 3,
1038 'pp_or' => 2, 'pp_xor' => 2,
1039 );
1040}
1041
1042sub deparse_binop_left {
1043 my $self = shift;
1044 my($op, $left, $prec) = @_;
1045 if ($left{assoc_class($op)}
1046 and $left{assoc_class($op)} == $left{assoc_class($left)})
1047 {
1048 return $self->deparse($left, $prec - .00001);
1049 } else {
1050 return $self->deparse($left, $prec);
1051 }
1052}
1053
1054# Right associative operators, like `=', for which
1055# $a = $b = $c is equivalent to $a = ($b = $c)
1056
1057BEGIN {
1058 %right = ('pp_pow' => 22,
1059 'pp_sassign=' => 7, 'pp_aassign=' => 7,
1060 'pp_multiply=' => 7, 'pp_i_multiply=' => 7,
1061 'pp_divide=' => 7, 'pp_i_divide=' => 7,
1062 'pp_modulo=' => 7, 'pp_i_modulo=' => 7,
1063 'pp_repeat=' => 7,
1064 'pp_add=' => 7, 'pp_i_add=' => 7,
1065 'pp_subtract=' => 7, 'pp_i_subtract=' => 7,
1066 'pp_concat=' => 7,
1067 'pp_left_shift=' => 7, 'pp_right_shift=' => 7,
1068 'pp_bit_and=' => 7,
1069 'pp_bit_or=' => 7, 'pp_bit_xor=' => 7,
1070 'pp_andassign' => 7,
1071 'pp_orassign' => 7,
1072 );
1073}
1074
1075sub deparse_binop_right {
1076 my $self = shift;
1077 my($op, $right, $prec) = @_;
1078 if ($right{assoc_class($op)}
1079 and $right{assoc_class($op)} == $right{assoc_class($right)})
1080 {
1081 return $self->deparse($right, $prec - .00001);
1082 } else {
1083 return $self->deparse($right, $prec);
1084 }
1085}
1086
a798dbf2 1087sub binop {
6e90668e 1088 my $self = shift;
9d2c6865 1089 my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
a798dbf2
MB
1090 my $left = $op->first;
1091 my $right = $op->last;
9d2c6865
SM
1092 my $eq = "";
1093 if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
1094 $eq = "=";
1095 $prec = 7;
1096 }
a798dbf2
MB
1097 if ($flags & SWAP_CHILDREN) {
1098 ($left, $right) = ($right, $left);
1099 }
9d2c6865
SM
1100 $left = $self->deparse_binop_left($op, $left, $prec);
1101 $right = $self->deparse_binop_right($op, $right, $prec);
1102 return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
1103}
1104
1105sub pp_add { binop(@_, "+", 18, ASSIGN) }
1106sub pp_multiply { binop(@_, "*", 19, ASSIGN) }
1107sub pp_subtract { binop(@_, "-",18, ASSIGN) }
1108sub pp_divide { binop(@_, "/", 19, ASSIGN) }
1109sub pp_modulo { binop(@_, "%", 19, ASSIGN) }
1110sub pp_i_add { binop(@_, "+", 18, ASSIGN) }
1111sub pp_i_multiply { binop(@_, "*", 19, ASSIGN) }
1112sub pp_i_subtract { binop(@_, "-", 18, ASSIGN) }
1113sub pp_i_divide { binop(@_, "/", 19, ASSIGN) }
1114sub pp_i_modulo { binop(@_, "%", 19, ASSIGN) }
1115sub pp_pow { binop(@_, "**", 22, ASSIGN) }
1116
1117sub pp_left_shift { binop(@_, "<<", 17, ASSIGN) }
1118sub pp_right_shift { binop(@_, ">>", 17, ASSIGN) }
1119sub pp_bit_and { binop(@_, "&", 13, ASSIGN) }
1120sub pp_bit_or { binop(@_, "|", 12, ASSIGN) }
1121sub pp_bit_xor { binop(@_, "^", 12, ASSIGN) }
1122
1123sub pp_eq { binop(@_, "==", 14) }
1124sub pp_ne { binop(@_, "!=", 14) }
1125sub pp_lt { binop(@_, "<", 15) }
1126sub pp_gt { binop(@_, ">", 15) }
1127sub pp_ge { binop(@_, ">=", 15) }
1128sub pp_le { binop(@_, "<=", 15) }
1129sub pp_ncmp { binop(@_, "<=>", 14) }
1130sub pp_i_eq { binop(@_, "==", 14) }
1131sub pp_i_ne { binop(@_, "!=", 14) }
1132sub pp_i_lt { binop(@_, "<", 15) }
1133sub pp_i_gt { binop(@_, ">", 15) }
1134sub pp_i_ge { binop(@_, ">=", 15) }
1135sub pp_i_le { binop(@_, "<=", 15) }
1136sub pp_i_ncmp { binop(@_, "<=>", 14) }
1137
1138sub pp_seq { binop(@_, "eq", 14) }
1139sub pp_sne { binop(@_, "ne", 14) }
1140sub pp_slt { binop(@_, "lt", 15) }
1141sub pp_sgt { binop(@_, "gt", 15) }
1142sub pp_sge { binop(@_, "ge", 15) }
1143sub pp_sle { binop(@_, "le", 15) }
1144sub pp_scmp { binop(@_, "cmp", 14) }
1145
1146sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
1147sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN) }
6e90668e
SM
1148
1149# `.' is special because concats-of-concats are optimized to save copying
1150# by making all but the first concat stacked. The effect is as if the
1151# programmer had written `($a . $b) .= $c', except legal.
1152sub pp_concat {
1153 my $self = shift;
9d2c6865 1154 my($op, $cx) = @_;
6e90668e
SM
1155 my $left = $op->first;
1156 my $right = $op->last;
1157 my $eq = "";
9d2c6865 1158 my $prec = 18;
6e90668e
SM
1159 if ($op->flags & OPf_STACKED and $op->first->ppaddr ne "pp_concat") {
1160 $eq = "=";
9d2c6865 1161 $prec = 7;
6e90668e 1162 }
9d2c6865
SM
1163 $left = $self->deparse_binop_left($op, $left, $prec);
1164 $right = $self->deparse_binop_right($op, $right, $prec);
1165 return $self->maybe_parens("$left .$eq $right", $cx, $prec);
6e90668e
SM
1166}
1167
1168# `x' is weird when the left arg is a list
1169sub pp_repeat {
1170 my $self = shift;
9d2c6865 1171 my($op, $cx) = @_;
6e90668e
SM
1172 my $left = $op->first;
1173 my $right = $op->last;
9d2c6865
SM
1174 my $eq = "";
1175 my $prec = 19;
1176 if ($op->flags & OPf_STACKED) {
1177 $eq = "=";
1178 $prec = 7;
1179 }
6e90668e
SM
1180 if (null($right)) { # list repeat; count is inside left-side ex-list
1181 my $kid = $left->first->sibling; # skip pushmark
1182 my @exprs;
1183 for (; !null($kid->sibling); $kid = $kid->sibling) {
9d2c6865 1184 push @exprs, $self->deparse($kid, 6);
6e90668e
SM
1185 }
1186 $right = $kid;
1187 $left = "(" . join(", ", @exprs). ")";
1188 } else {
9d2c6865 1189 $left = $self->deparse_binop_left($op, $left, $prec);
6e90668e 1190 }
9d2c6865
SM
1191 $right = $self->deparse_binop_right($op, $right, $prec);
1192 return $self->maybe_parens("$left x$eq $right", $cx, $prec);
6e90668e
SM
1193}
1194
1195sub range {
1196 my $self = shift;
9d2c6865 1197 my ($op, $cx, $type) = @_;
6e90668e
SM
1198 my $left = $op->first;
1199 my $right = $left->sibling;
9d2c6865
SM
1200 $left = $self->deparse($left, 9);
1201 $right = $self->deparse($right, 9);
1202 return $self->maybe_parens("$left $type $right", $cx, 9);
6e90668e
SM
1203}
1204
1205sub pp_flop {
1206 my $self = shift;
9d2c6865 1207 my($op, $cx) = @_;
6e90668e
SM
1208 my $flip = $op->first;
1209 my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
9d2c6865 1210 return $self->range($flip->first, $cx, $type);
6e90668e
SM
1211}
1212
1213# one-line while/until is handled in pp_leave
1214
1215sub logop {
1216 my $self = shift;
9d2c6865 1217 my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
6e90668e
SM
1218 my $left = $op->first;
1219 my $right = $op->first->sibling;
9d2c6865
SM
1220 if ($cx == 0 and is_scope($right) and $blockname) { # if ($a) {$b}
1221 $left = $self->deparse($left, 1);
1222 $right = $self->deparse($right, 0);
1223 return "$blockname ($left) {\n\t$right\n\b}\cK";
1224 } elsif ($cx == 0 and $blockname and not $self->{'parens'}) { # $b if $a
1225 $right = $self->deparse($right, 1);
1226 $left = $self->deparse($left, 1);
1227 return "$right $blockname $left";
1228 } elsif ($cx > $lowprec and $highop) { # $a && $b
1229 $left = $self->deparse_binop_left($op, $left, $highprec);
1230 $right = $self->deparse_binop_right($op, $right, $highprec);
1231 return $self->maybe_parens("$left $highop $right", $cx, $highprec);
1232 } else { # $a and $b
1233 $left = $self->deparse_binop_left($op, $left, $lowprec);
1234 $right = $self->deparse_binop_right($op, $right, $lowprec);
1235 return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
1236 }
1237}
1238
1239sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
1240sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
1241sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
6e90668e
SM
1242
1243sub logassignop {
1244 my $self = shift;
9d2c6865 1245 my ($op, $cx, $opname) = @_;
6e90668e
SM
1246 my $left = $op->first;
1247 my $right = $op->first->sibling->first; # skip sassign
9d2c6865
SM
1248 $left = $self->deparse($left, 7);
1249 $right = $self->deparse($right, 7);
1250 return $self->maybe_parens("$left $opname $right", $cx, 7);
a798dbf2
MB
1251}
1252
6e90668e
SM
1253sub pp_andassign { logassignop(@_, "&&=") }
1254sub pp_orassign { logassignop(@_, "||=") }
1255
1256sub listop {
1257 my $self = shift;
9d2c6865
SM
1258 my($op, $cx, $name) = @_;
1259 my(@exprs);
1260 my $parens = ($cx >= 5) || $self->{'parens'};
1261 my $kid = $op->first->sibling;
1262 return $name if null $kid;
1263 my $first = $self->deparse($kid, 6);
1264 $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
1265 push @exprs, $first;
1266 $kid = $kid->sibling;
1267 for (; !null($kid); $kid = $kid->sibling) {
1268 push @exprs, $self->deparse($kid, 6);
1269 }
1270 if ($parens) {
1271 return "$name(" . join(", ", @exprs) . ")";
1272 } else {
1273 return "$name " . join(", ", @exprs);
6e90668e 1274 }
6e90668e 1275}
a798dbf2 1276
6e90668e
SM
1277sub pp_bless { listop(@_, "bless") }
1278sub pp_atan2 { listop(@_, "atan2") }
1279sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
1280sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
1281sub pp_index { listop(@_, "index") }
1282sub pp_rindex { listop(@_, "rindex") }
1283sub pp_sprintf { listop(@_, "sprintf") }
1284sub pp_formline { listop(@_, "formline") } # see also deparse_format
1285sub pp_crypt { listop(@_, "crypt") }
1286sub pp_unpack { listop(@_, "unpack") }
1287sub pp_pack { listop(@_, "pack") }
1288sub pp_join { listop(@_, "join") }
1289sub pp_splice { listop(@_, "splice") }
1290sub pp_push { listop(@_, "push") }
1291sub pp_unshift { listop(@_, "unshift") }
1292sub pp_reverse { listop(@_, "reverse") }
1293sub pp_warn { listop(@_, "warn") }
1294sub pp_die { listop(@_, "die") }
9d2c6865
SM
1295# Actually, return is exempt from the LLAFR (see examples in this very
1296# module!), but for consistency's sake, ignore that fact
6e90668e
SM
1297sub pp_return { listop(@_, "return") }
1298sub pp_open { listop(@_, "open") }
1299sub pp_pipe_op { listop(@_, "pipe") }
1300sub pp_tie { listop(@_, "tie") }
1301sub pp_dbmopen { listop(@_, "dbmopen") }
1302sub pp_sselect { listop(@_, "select") }
1303sub pp_select { listop(@_, "select") }
1304sub pp_read { listop(@_, "read") }
1305sub pp_sysopen { listop(@_, "sysopen") }
1306sub pp_sysseek { listop(@_, "sysseek") }
1307sub pp_sysread { listop(@_, "sysread") }
1308sub pp_syswrite { listop(@_, "syswrite") }
1309sub pp_send { listop(@_, "send") }
1310sub pp_recv { listop(@_, "recv") }
1311sub pp_seek { listop(@_, "seek") }
1312sub pp_truncate { listop(@_, "truncate") }
1313sub pp_fcntl { listop(@_, "fcntl") }
1314sub pp_ioctl { listop(@_, "ioctl") }
1315sub pp_flock { listop(@_, "flock") }
1316sub pp_socket { listop(@_, "socket") }
1317sub pp_sockpair { listop(@_, "sockpair") }
1318sub pp_bind { listop(@_, "bind") }
1319sub pp_connect { listop(@_, "connect") }
1320sub pp_listen { listop(@_, "listen") }
1321sub pp_accept { listop(@_, "accept") }
1322sub pp_shutdown { listop(@_, "shutdown") }
1323sub pp_gsockopt { listop(@_, "getsockopt") }
1324sub pp_ssockopt { listop(@_, "setsockopt") }
1325sub pp_chown { listop(@_, "chown") }
1326sub pp_unlink { listop(@_, "unlink") }
1327sub pp_chmod { listop(@_, "chmod") }
1328sub pp_utime { listop(@_, "utime") }
1329sub pp_rename { listop(@_, "rename") }
1330sub pp_link { listop(@_, "link") }
1331sub pp_symlink { listop(@_, "symlink") }
1332sub pp_mkdir { listop(@_, "mkdir") }
1333sub pp_open_dir { listop(@_, "opendir") }
1334sub pp_seekdir { listop(@_, "seekdir") }
1335sub pp_waitpid { listop(@_, "waitpid") }
1336sub pp_system { listop(@_, "system") }
1337sub pp_exec { listop(@_, "exec") }
1338sub pp_kill { listop(@_, "kill") }
1339sub pp_setpgrp { listop(@_, "setpgrp") }
1340sub pp_getpriority { listop(@_, "getpriority") }
1341sub pp_setpriority { listop(@_, "setpriority") }
1342sub pp_shmget { listop(@_, "shmget") }
1343sub pp_shmctl { listop(@_, "shmctl") }
1344sub pp_shmread { listop(@_, "shmread") }
1345sub pp_shmwrite { listop(@_, "shmwrite") }
1346sub pp_msgget { listop(@_, "msgget") }
1347sub pp_msgctl { listop(@_, "msgctl") }
1348sub pp_msgsnd { listop(@_, "msgsnd") }
1349sub pp_msgrcv { listop(@_, "msgrcv") }
1350sub pp_semget { listop(@_, "semget") }
1351sub pp_semctl { listop(@_, "semctl") }
1352sub pp_semop { listop(@_, "semop") }
1353sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
1354sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
1355sub pp_gpbynumber { listop(@_, "getprotobynumber") }
1356sub pp_gsbyname { listop(@_, "getservbyname") }
1357sub pp_gsbyport { listop(@_, "getservbyport") }
1358sub pp_syscall { listop(@_, "syscall") }
1359
1360sub pp_glob {
1361 my $self = shift;
9d2c6865 1362 my($op, $cx) = @_;
6e90668e
SM
1363 my $text = $self->dq($op->first->sibling); # skip pushmark
1364 if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
1365 or $text =~ /[<>]/) {
1366 return 'glob(' . single_delim('qq', '"', $text) . ')';
1367 } else {
1368 return '<' . $text . '>';
1369 }
1370}
1371
1372sub indirop {
1373 my $self = shift;
9d2c6865 1374 my($op, $cx, $name) = @_;
6e90668e
SM
1375 my($expr, @exprs);
1376 my $kid = $op->first->sibling;
1377 my $indir = "";
1378 if ($op->flags & OPf_STACKED) {
1379 $indir = $kid;
1380 $indir = $indir->first; # skip rv2gv
1381 if (is_scope($indir)) {
9d2c6865 1382 $indir = "{" . $self->deparse($indir, 0) . "}";
6e90668e 1383 } else {
9d2c6865 1384 $indir = $self->deparse($indir, 24);
6e90668e
SM
1385 }
1386 $indir = $indir . " ";
1387 $kid = $kid->sibling;
1388 }
1389 for (; !null($kid); $kid = $kid->sibling) {
9d2c6865 1390 $expr = $self->deparse($kid, 6);
6e90668e
SM
1391 push @exprs, $expr;
1392 }
9d2c6865
SM
1393 return $self->maybe_parens_func($name,
1394 $indir . join(", ", @exprs),
1395 $cx, 5);
6e90668e
SM
1396}
1397
1398sub pp_prtf { indirop(@_, "printf") }
1399sub pp_print { indirop(@_, "print") }
1400sub pp_sort { indirop(@_, "sort") }
1401
1402sub mapop {
1403 my $self = shift;
9d2c6865 1404 my($op, $cx, $name) = @_;
6e90668e
SM
1405 my($expr, @exprs);
1406 my $kid = $op->first; # this is the (map|grep)start
1407 $kid = $kid->first->sibling; # skip a pushmark
1408 my $code = $kid->first; # skip a null
1409 if (is_scope $code) {
9d2c6865 1410 $code = "{" . $self->deparse($code, 1) . "} ";
6e90668e 1411 } else {
9d2c6865 1412 $code = $self->deparse($code, 24) . ", ";
6e90668e
SM
1413 }
1414 $kid = $kid->sibling;
1415 for (; !null($kid); $kid = $kid->sibling) {
9d2c6865 1416 $expr = $self->deparse($kid, 6);
6e90668e
SM
1417 push @exprs, $expr if $expr;
1418 }
9d2c6865 1419 return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
6e90668e
SM
1420}
1421
1422sub pp_mapwhile { mapop(@_, "map") }
1423sub pp_grepwhile { mapop(@_, "grep") }
1424
1425sub pp_list {
1426 my $self = shift;
9d2c6865 1427 my($op, $cx) = @_;
6e90668e
SM
1428 my($expr, @exprs);
1429 my $kid = $op->first->sibling; # skip pushmark
9d2c6865 1430 return $self->deparse($kid, $cx) if null $kid->sibling;
6e90668e
SM
1431 my $lop;
1432 my $local = "either"; # could be local(...) or my(...)
1433 for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
1434 # This assumes that no other private flags equal 128, and that
1435 # OPs that store things other than flags in their op_private,
1436 # like OP_AELEMFAST, won't be immediate children of a list.
1437 unless ($lop->private & OPp_LVAL_INTRO or $lop->ppaddr eq "pp_undef")
1438 {
1439 $local = ""; # or not
1440 last;
1441 }
1442 if ($lop->ppaddr =~ /^pp_pad[ash]v$/) { # my()
1443 ($local = "", last) if $local eq "local";
1444 $local = "my";
1445 } elsif ($lop->ppaddr ne "pp_undef") { # local()
1446 ($local = "", last) if $local eq "my";
1447 $local = "local";
1448 }
1449 }
1450 $local = "" if $local eq "either"; # no point if it's all undefs
1451 for (; !null($kid); $kid = $kid->sibling) {
1452 if ($local) {
1453 if (class($kid) eq "UNOP" and $kid->first->ppaddr eq "pp_gvsv") {
1454 $lop = $kid->first;
1455 } else {
1456 $lop = $kid;
1457 }
1458 $self->{'avoid_local'}{$$lop}++;
9d2c6865 1459 $expr = $self->deparse($kid, 6);
6e90668e
SM
1460 delete $self->{'avoid_local'}{$$lop};
1461 } else {
9d2c6865 1462 $expr = $self->deparse($kid, 6);
6e90668e
SM
1463 }
1464 push @exprs, $expr;
1465 }
9d2c6865
SM
1466 if ($local) {
1467 return "$local(" . join(", ", @exprs) . ")";
1468 } else {
1469 return $self->maybe_parens( join(", ", @exprs), $cx, 6);
1470 }
6e90668e
SM
1471}
1472
1473sub pp_cond_expr {
1474 my $self = shift;
9d2c6865 1475 my($op, $cx) = @_;
6e90668e
SM
1476 my $cond = $op->first;
1477 my $true = $cond->sibling;
1478 my $false = $true->sibling;
9d2c6865
SM
1479 my $cuddle = $self->{'cuddle'};
1480 $cond = $self->deparse($cond, 1);
1481 unless ($cx == 0 and is_scope($true) and is_scope($false)) {
1482 $true = $self->deparse($true, 8);
1483 $false = $self->deparse($false, 8);
1484 return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
1485 }
1486 $true = $self->deparse($true, 0);
6e90668e
SM
1487 if ($false->ppaddr eq "pp_lineseq") { # braces w/o scope => elsif
1488 my $head = "if ($cond) {\n\t$true\n\b}";
1489 my @elsifs;
1490 while (!null($false) and $false->ppaddr eq "pp_lineseq") {
1491 my $newop = $false->first->sibling->first;
1492 my $newcond = $newop->first;
1493 my $newtrue = $newcond->sibling;
1494 $false = $newtrue->sibling; # last in chain is OP_AND => no else
9d2c6865
SM
1495 $newcond = $self->deparse($newcond, 1);
1496 $newtrue = $self->deparse($newtrue, 0);
6e90668e
SM
1497 push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
1498 }
1499 if (!null($false)) {
9d2c6865
SM
1500 $false = $cuddle . "else {\n\t" .
1501 $self->deparse($false, 0) . "\n\b}\cK";
6e90668e 1502 } else {
9d2c6865 1503 $false = "\cK";
6e90668e 1504 }
9d2c6865 1505 return $head . join($cuddle, "", @elsifs) . $false;
6e90668e 1506 }
9d2c6865
SM
1507 $false = $self->deparse($false, 0);
1508 return "if ($cond) {\n\t$true\n\b}${cuddle}else {\n\t$false\n\b}\cK";
6e90668e
SM
1509}
1510
1511sub pp_leaveloop {
1512 my $self = shift;
9d2c6865 1513 my($op, $cx) = @_;
6e90668e
SM
1514 my $enter = $op->first;
1515 my $kid = $enter->sibling;
1516 local($self->{'curstash'}) = $self->{'curstash'};
1517 my $head = "";
9d2c6865 1518 my $bare = 0;
6e90668e
SM
1519 if ($kid->ppaddr eq "pp_lineseq") { # bare or infinite loop
1520 if (is_state $kid->last) { # infinite
1521 $head = "for (;;) "; # shorter than while (1)
9d2c6865
SM
1522 } else {
1523 $bare = 1;
6e90668e
SM
1524 }
1525 } elsif ($enter->ppaddr eq "pp_enteriter") { # foreach
1526 my $ary = $enter->first->sibling; # first was pushmark
1527 my $var = $ary->sibling;
d8d95777 1528 if ($enter->flags & OPf_STACKED) {
d7f5b6da
SM
1529 $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
1530 $self->deparse($ary->first->sibling->sibling, 9);
d8d95777
GA
1531 } else {
1532 $ary = $self->deparse($ary, 1);
1533 }
6e90668e 1534 if (null $var) {
f6f9bdb7 1535 if ($enter->flags & OPf_SPECIAL) { # thread special var
9d2c6865 1536 $var = $self->pp_threadsv($enter, 1);
f6f9bdb7 1537 } else { # regular my() variable
9d2c6865 1538 $var = $self->pp_padsv($enter, 1);
f6f9bdb7
SM
1539 if ($self->padname_sv($enter->targ)->IVX ==
1540 $kid->first->first->sibling->last->cop_seq)
1541 {
1542 # If the scope of this variable closes at the last
1543 # statement of the loop, it must have been
1544 # declared here.
1545 $var = "my " . $var;
1546 }
6e90668e
SM
1547 }
1548 } elsif ($var->ppaddr eq "pp_rv2gv") {
9d2c6865 1549 $var = $self->pp_rv2sv($var, 1);
6e90668e 1550 } elsif ($var->ppaddr eq "pp_gv") {
9d2c6865 1551 $var = "\$" . $self->deparse($var, 1);
6e90668e 1552 }
9d2c6865 1553 $head = "foreach $var ($ary) ";
6e90668e
SM
1554 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1555 } elsif ($kid->ppaddr eq "pp_null") { # while/until
1556 $kid = $kid->first;
1557 my $name = {"pp_and" => "while", "pp_or" => "until"}
1558 ->{$kid->ppaddr};
9d2c6865 1559 $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
6e90668e 1560 $kid = $kid->first->sibling;
9d2c6865
SM
1561 } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty
1562 return "{;}"; # {} could be a hashref
6e90668e
SM
1563 }
1564 # The third-to-last kid is the continue block if the pointer used
9d2c6865
SM
1565 # by `next BLOCK' points to its first OP, which happens to be the
1566 # the op_next of the head of the _previous_ statement.
1567 # Unless it's a bare loop, in which case it's last, since there's
1568 # no unstack or extra nextstate.
1569 my($cont, $precont);
1570 if ($bare) {
6e90668e 1571 $cont = $kid->first;
9d2c6865
SM
1572 while (!null($cont->sibling)) {
1573 $precont = $cont;
1574 $cont = $cont->sibling;
1575 }
1576 } else {
1577 $cont = $kid->first;
1578 while (!null($cont->sibling->sibling->sibling)) {
1579 $precont = $cont;
1580 $cont = $cont->sibling;
6e90668e
SM
1581 }
1582 }
9d2c6865
SM
1583# cluck $self->{'curcv'}->GV->NAME unless $precont;
1584 if ($precont and $ {$precont->next} == $ {$enter->nextop}) {
6e90668e 1585 my $state = $kid->first;
9d2c6865 1586 my $cuddle = $self->{'cuddle'};
6e90668e
SM
1587 my($expr, @exprs);
1588 for (; $$state != $$cont; $state = $state->sibling) {
1589 $expr = "";
1590 if (is_state $state) {
9d2c6865 1591 $expr = $self->deparse($state, 0);
6e90668e
SM
1592 $state = $state->sibling;
1593 last if null $kid;
1594 }
9d2c6865 1595 $expr .= $self->deparse($state, 0);
6e90668e
SM
1596 push @exprs, $expr if $expr;
1597 }
1598 $kid = join(";\n", @exprs);
9d2c6865
SM
1599 $cont = $cuddle . "continue {\n\t" .
1600 $self->deparse($cont, 0) . "\n\b}\cK";
6e90668e 1601 } else {
9d2c6865
SM
1602 $cont = "\cK";
1603 $kid = $self->deparse($kid, 0);
6e90668e
SM
1604 }
1605 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1606}
1607
1608sub pp_leavetry {
1609 my $self = shift;
9d2c6865 1610 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
6e90668e
SM
1611}
1612
1613sub OP_CONST () { 5 }
1614sub OP_STRINGIFY () { 65 }
a798dbf2
MB
1615
1616sub pp_null {
6e90668e 1617 my $self = shift;
9d2c6865 1618 my($op, $cx) = @_;
6e90668e
SM
1619 if (class($op) eq "OP") {
1620 return "'???'" if $op->targ == OP_CONST; # old value is lost
1621 } elsif ($op->first->ppaddr eq "pp_pushmark") {
9d2c6865 1622 return $self->pp_list($op, $cx);
6e90668e 1623 } elsif ($op->first->ppaddr eq "pp_enter") {
9d2c6865 1624 return $self->pp_leave($op, $cx);
6e90668e
SM
1625 } elsif ($op->targ == OP_STRINGIFY) {
1626 return $self->dquote($op);
1627 } elsif (!null($op->first->sibling) and
1628 $op->first->sibling->ppaddr eq "pp_readline" and
1629 $op->first->sibling->flags & OPf_STACKED) {
9d2c6865
SM
1630 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1631 . $self->deparse($op->first->sibling, 7),
1632 $cx, 7);
6e90668e
SM
1633 } elsif (!null($op->first->sibling) and
1634 $op->first->sibling->ppaddr eq "pp_trans" and
1635 $op->first->sibling->flags & OPf_STACKED) {
9d2c6865
SM
1636 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1637 . $self->deparse($op->first->sibling, 20),
1638 $cx, 20);
6e90668e 1639 } else {
9d2c6865 1640 return $self->deparse($op->first, $cx);
6e90668e 1641 }
a798dbf2
MB
1642}
1643
6e90668e
SM
1644sub padname {
1645 my $self = shift;
1646 my $targ = shift;
1647 my $str = $self->padname_sv($targ)->PV;
1648 return padname_fix($str);
1649}
1650
1651sub padany {
1652 my $self = shift;
1653 my $op = shift;
1654 return substr($self->padname($op->targ), 1); # skip $/@/%
1655}
1656
1657sub pp_padsv {
1658 my $self = shift;
9d2c6865
SM
1659 my($op, $cx) = @_;
1660 return $self->maybe_my($op, $cx, $self->padname($op->targ));
6e90668e
SM
1661}
1662
1663sub pp_padav { pp_padsv(@_) }
1664sub pp_padhv { pp_padsv(@_) }
1665
9d2c6865
SM
1666my @threadsv_names;
1667
1668BEGIN {
1669 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1670 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1671 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1672 "!", "@");
1673}
f6f9bdb7
SM
1674
1675sub pp_threadsv {
1676 my $self = shift;
9d2c6865
SM
1677 my($op, $cx) = @_;
1678 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
f6f9bdb7
SM
1679}
1680
6e90668e
SM
1681sub pp_gvsv {
1682 my $self = shift;
9d2c6865
SM
1683 my($op, $cx) = @_;
1684 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
6e90668e
SM
1685}
1686
1687sub pp_gv {
1688 my $self = shift;
9d2c6865 1689 my($op, $cx) = @_;
6e90668e
SM
1690 return $self->gv_name($op->gv);
1691}
1692
1693sub pp_aelemfast {
1694 my $self = shift;
9d2c6865 1695 my($op, $cx) = @_;
6e90668e
SM
1696 my $gv = $op->gv;
1697 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1698}
1699
1700sub rv2x {
1701 my $self = shift;
9d2c6865 1702 my($op, $cx, $type) = @_;
6e90668e
SM
1703 my $kid = $op->first;
1704 my $scope = is_scope($kid);
9d2c6865 1705 $kid = $self->deparse($kid, 0);
6e90668e
SM
1706 return $type . ($scope ? "{$kid}" : $kid);
1707}
1708
1709sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1710sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1711sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1712
1713# skip rv2av
1714sub pp_av2arylen {
1715 my $self = shift;
9d2c6865 1716 my($op, $cx) = @_;
6e90668e 1717 if ($op->first->ppaddr eq "pp_padav") {
9d2c6865 1718 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
6e90668e 1719 } else {
9d2c6865 1720 return $self->maybe_local($op, $cx, $self->rv2x($op->first, '$#'));
6e90668e
SM
1721 }
1722}
1723
1724# skip down to the old, ex-rv2cv
9d2c6865 1725sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
6e90668e
SM
1726
1727sub pp_rv2av {
1728 my $self = shift;
9d2c6865 1729 my($op, $cx) = @_;
6e90668e
SM
1730 my $kid = $op->first;
1731 if ($kid->ppaddr eq "pp_const") { # constant list
1732 my $av = $kid->sv;
1733 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1734 } else {
9d2c6865 1735 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
6e90668e
SM
1736 }
1737 }
1738
1739
1740sub elem {
1741 my $self = shift;
9d2c6865 1742 my ($op, $cx, $left, $right, $padname) = @_;
6e90668e
SM
1743 my($array, $idx) = ($op->first, $op->first->sibling);
1744 unless ($array->ppaddr eq $padname) { # Maybe this has been fixed
1745 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1746 }
1747 if ($array->ppaddr eq $padname) {
1748 $array = $self->padany($array);
1749 } elsif (is_scope($array)) { # ${expr}[0]
9d2c6865 1750 $array = "{" . $self->deparse($array, 0) . "}";
6e90668e 1751 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
9d2c6865 1752 $array = $self->deparse($array, 24);
6e90668e
SM
1753 } else {
1754 # $x[20][3]{hi} or expr->[20]
1755 my $arrow;
1756 $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/;
9d2c6865
SM
1757 return $self->deparse($array, 24) . $arrow .
1758 $left . $self->deparse($idx, 1) . $right;
6e90668e 1759 }
9d2c6865 1760 $idx = $self->deparse($idx, 1);
6e90668e
SM
1761 return "\$" . $array . $left . $idx . $right;
1762}
1763
1764sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) }
1765sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) }
1766
1767sub pp_gelem {
1768 my $self = shift;
9d2c6865 1769 my($op, $cx) = @_;
6e90668e
SM
1770 my($glob, $part) = ($op->first, $op->last);
1771 $glob = $glob->first; # skip rv2gv
1772 $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug
9d2c6865
SM
1773 my $scope = is_scope($glob);
1774 $glob = $self->deparse($glob, 0);
1775 $part = $self->deparse($part, 1);
6e90668e
SM
1776 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1777}
1778
1779sub slice {
1780 my $self = shift;
9d2c6865 1781 my ($op, $cx, $left, $right, $regname, $padname) = @_;
6e90668e
SM
1782 my $last;
1783 my(@elems, $kid, $array, $list);
1784 if (class($op) eq "LISTOP") {
1785 $last = $op->last;
1786 } else { # ex-hslice inside delete()
1787 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
1788 $last = $kid;
1789 }
1790 $array = $last;
1791 $array = $array->first
1792 if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null";
1793 if (is_scope($array)) {
9d2c6865 1794 $array = "{" . $self->deparse($array, 0) . "}";
6e90668e
SM
1795 } elsif ($array->ppaddr eq $padname) {
1796 $array = $self->padany($array);
1797 } else {
9d2c6865 1798 $array = $self->deparse($array, 24);
6e90668e
SM
1799 }
1800 $kid = $op->first->sibling; # skip pushmark
1801 if ($kid->ppaddr eq "pp_list") {
1802 $kid = $kid->first->sibling; # skip list, pushmark
1803 for (; !null $kid; $kid = $kid->sibling) {
9d2c6865 1804 push @elems, $self->deparse($kid, 6);
6e90668e
SM
1805 }
1806 $list = join(", ", @elems);
1807 } else {
9d2c6865 1808 $list = $self->deparse($kid, 1);
6e90668e
SM
1809 }
1810 return "\@" . $array . $left . $list . $right;
1811}
1812
1813sub pp_aslice { maybe_local(@_, slice(@_, "[", "]",
1814 "pp_rv2av", "pp_padav")) }
1815sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
1816 "pp_rv2hv", "pp_padhv")) }
1817
1818sub pp_lslice {
1819 my $self = shift;
9d2c6865 1820 my($op, $cx) = @_;
6e90668e
SM
1821 my $idx = $op->first;
1822 my $list = $op->last;
1823 my(@elems, $kid);
9d2c6865
SM
1824 $list = $self->deparse($list, 1);
1825 $idx = $self->deparse($idx, 1);
1826 return "($list)" . "[$idx]";
6e90668e
SM
1827}
1828
1829sub OPpENTERSUB_AMPER () { 8 }
1830
1831sub OPf_WANT () { 3 }
1832sub OPf_WANT_VOID () { 1 }
1833sub OPf_WANT_SCALAR () { 2 }
1834sub OPf_WANT_LIST () { 2 }
1835
1836sub want_scalar {
1837 my $op = shift;
1838 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
1839}
1840
1841sub pp_entersub {
1842 my $self = shift;
9d2c6865 1843 my($op, $cx) = @_;
6e90668e
SM
1844 my $prefix = "";
1845 my $amper = "";
1846 my $proto = undef;
9d2c6865 1847 my $simple = 0;
6e90668e 1848 my($kid, $args, @exprs);
9d2c6865 1849 if (not null $op->first->sibling) { # method
6e90668e 1850 $kid = $op->first->sibling; # skip pushmark
9d2c6865 1851 my $obj = $self->deparse($kid, 24);
6e90668e
SM
1852 $kid = $kid->sibling;
1853 for (; not null $kid->sibling; $kid = $kid->sibling) {
9d2c6865 1854 push @exprs, $self->deparse($kid, 6);
6e90668e
SM
1855 }
1856 my $meth = $kid->first;
1857 if ($meth->ppaddr eq "pp_const") {
1858 $meth = $meth->sv->PV; # needs to be bare
1859 } else {
9d2c6865 1860 $meth = $self->deparse($meth, 1);
6e90668e 1861 }
6e90668e
SM
1862 $args = join(", ", @exprs);
1863 $kid = $obj . "->" . $meth;
9d2c6865
SM
1864 if ($args) {
1865 return $kid . "(" . $args . ")"; # parens mandatory
6e90668e 1866 } else {
9d2c6865 1867 return $kid; # toke.c fakes parens
6e90668e 1868 }
9d2c6865
SM
1869 }
1870 # else, not a method
1871 if ($op->flags & OPf_SPECIAL) {
1872 $prefix = "do ";
1873 } elsif ($op->private & OPpENTERSUB_AMPER) {
1874 $amper = "&";
1875 }
1876 $kid = $op->first;
1877 $kid = $kid->first->sibling; # skip ex-list, pushmark
1878 for (; not null $kid->sibling; $kid = $kid->sibling) {
1879 push @exprs, $kid;
1880 }
1881 if (is_scope($kid)) {
1882 $amper = "&";
1883 $kid = "{" . $self->deparse($kid, 0) . "}";
1884 } elsif ($kid->first->ppaddr eq "pp_gv") {
1885 my $gv = $kid->first->gv;
1886 if (class($gv->CV) ne "SPECIAL") {
1887 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
1888 }
1889 $simple = 1;
1890 $kid = $self->deparse($kid, 24);
1891 } elsif (is_scalar $kid->first) {
1892 $amper = "&";
1893 $kid = $self->deparse($kid, 24);
1894 } else {
1895 $prefix = "";
1896 $kid = $self->deparse($kid, 24) . "->";
1897 }
1898 if (defined $proto and not $amper) {
1899 my($arg, $real);
1900 my $doneok = 0;
1901 my @args = @exprs;
1902 my @reals;
1903 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
1904 while ($proto) {
1905 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
1906 my $chr = $1;
1907 if ($chr eq "") {
1908 undef $proto if @args;
1909 } elsif ($chr eq ";") {
1910 $doneok = 1;
1911 } elsif ($chr eq "@" or $chr eq "%") {
1912 push @reals, map($self->deparse($_, 6), @args);
1913 @args = ();
1914 } else {
1915 $arg = shift @args;
1916 undef $proto, last unless $arg;
1917 if ($chr eq "\$") {
1918 if (want_scalar $arg) {
1919 push @reals, $self->deparse($arg, 6);
1920 } else {
1921 undef $proto;
1922 }
1923 } elsif ($chr eq "&") {
1924 if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
1925 push @reals, $self->deparse($arg, 6);
1926 } else {
1927 undef $proto;
1928 }
1929 } elsif ($chr eq "*") {
1930 if ($arg->ppaddr =~ /^pp_s?refgen$/
1931 and $arg->first->first->ppaddr eq "pp_rv2gv")
1932 {
1933 $real = $arg->first->first; # skip refgen, null
1934 if ($real->first->ppaddr eq "pp_gv") {
1935 push @reals, $self->deparse($real, 6);
6e90668e 1936 } else {
9d2c6865 1937 push @reals, $self->deparse($real->first, 6);
6e90668e 1938 }
9d2c6865
SM
1939 } else {
1940 undef $proto;
1941 }
1942 } elsif (substr($chr, 0, 1) eq "\\") {
1943 $chr = substr($chr, 1);
1944 if ($arg->ppaddr =~ /^pp_s?refgen$/ and
1945 !null($real = $arg->first) and
1946 ($chr eq "\$" && is_scalar($real->first)
1947 or ($chr eq "\@"
1948 && $real->first->sibling->ppaddr
1949 =~ /^pp_(rv2|pad)av$/)
1950 or ($chr eq "%"
1951 && $real->first->sibling->ppaddr
1952 =~ /^pp_(rv2|pad)hv$/)
1953 #or ($chr eq "&" # This doesn't work
1954 # && $real->first->ppaddr eq "pp_rv2cv")
1955 or ($chr eq "*"
1956 && $real->first->ppaddr eq "pp_rv2gv")))
1957 {
1958 push @reals, $self->deparse($real, 6);
1959 } else {
1960 undef $proto;
6e90668e
SM
1961 }
1962 }
1963 }
6e90668e 1964 }
9d2c6865
SM
1965 undef $proto if $proto and !$doneok;
1966 undef $proto if @args;
1967 $args = join(", ", @reals);
1968 $amper = "";
1969 unless (defined $proto) {
1970 $amper = "&";
1971 $args = join(", ", map($self->deparse($_, 6), @exprs));
1972 }
1973 } else {
1974 $args = join(", ", map($self->deparse($_, 6), @exprs));
6e90668e 1975 }
9d2c6865
SM
1976 if ($prefix or $amper) {
1977 if ($op->flags & OPf_STACKED) {
1978 return $prefix . $amper . $kid . "(" . $args . ")";
1979 } else {
1980 return $prefix . $amper. $kid;
1981 }
6e90668e 1982 } else {
9d2c6865
SM
1983 if (defined $proto and $proto eq "") {
1984 return $kid;
1985 } elsif ($proto eq "\$") {
1986 return $self->maybe_parens_func($kid, $args, $cx, 16);
1987 } elsif ($proto or $simple) {
1988 return $self->maybe_parens_func($kid, $args, $cx, 5);
1989 } else {
1990 return "$kid(" . $args . ")";
1991 }
6e90668e
SM
1992 }
1993}
1994
1995sub pp_enterwrite { unop(@_, "write") }
1996
1997# escape things that cause interpolation in double quotes,
1998# but not character escapes
1999sub uninterp {
2000 my($str) = @_;
9d2c6865
SM
2001 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
2002 return $str;
2003}
2004
2005# the same, but treat $|, $), and $ at the end of the string differently
2006sub re_uninterp {
2007 my($str) = @_;
2008 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
2009 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
6e90668e
SM
2010 return $str;
2011}
2012
2013# character escapes, but not delimiters that might need to be escaped
2014sub escape_str { # ASCII
2015 my($str) = @_;
6e90668e
SM
2016 $str =~ s/\a/\\a/g;
2017# $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2018 $str =~ s/\t/\\t/g;
2019 $str =~ s/\n/\\n/g;
2020 $str =~ s/\e/\\e/g;
2021 $str =~ s/\f/\\f/g;
2022 $str =~ s/\r/\\r/g;
2023 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2024 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2025 return $str;
2026}
2027
9d2c6865
SM
2028# Don't do this for regexen
2029sub unback {
2030 my($str) = @_;
2031 $str =~ s/\\/\\\\/g;
2032 return $str;
2033}
2034
6e90668e
SM
2035sub balanced_delim {
2036 my($str) = @_;
2037 my @str = split //, $str;
2038 my($ar, $open, $close, $fail, $c, $cnt);
2039 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2040 ($open, $close) = @$ar;
2041 $fail = 0; $cnt = 0;
2042 for $c (@str) {
2043 if ($c eq $open) {
2044 $cnt++;
2045 } elsif ($c eq $close) {
2046 $cnt--;
2047 if ($cnt < 0) {
2048 $fail = 1;
2049 last;
2050 }
2051 }
2052 }
2053 $fail = 1 if $cnt != 0;
2054 return ($open, "$open$str$close") if not $fail;
2055 }
2056 return ("", $str);
2057}
2058
2059sub single_delim {
2060 my($q, $default, $str) = @_;
90be192f 2061 return "$default$str$default" if $default and index($str, $default) == -1;
6e90668e
SM
2062 my($succeed, $delim);
2063 ($succeed, $str) = balanced_delim($str);
2064 return "$q$str" if $succeed;
2065 for $delim ('/', '"', '#') {
2066 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2067 }
90be192f
SM
2068 if ($default) {
2069 $str =~ s/$default/\\$default/g;
2070 return "$default$str$default";
2071 } else {
2072 $str =~ s[/][\\/]g;
2073 return "$q/$str/";
2074 }
6e90668e
SM
2075}
2076
2077sub SVf_IOK () {0x10000}
2078sub SVf_NOK () {0x20000}
2079sub SVf_ROK () {0x80000}
2080
2081sub const {
2082 my $sv = shift;
2083 if (class($sv) eq "SPECIAL") {
9d2c6865 2084 return ('undef', '1', '0')[$$sv-1];
6e90668e 2085 } elsif ($sv->FLAGS & SVf_IOK) {
a798dbf2 2086 return $sv->IV;
6e90668e 2087 } elsif ($sv->FLAGS & SVf_NOK) {
a798dbf2 2088 return $sv->NV;
6e90668e
SM
2089 } elsif ($sv->FLAGS & SVf_ROK) {
2090 return "\\(" . const($sv->RV) . ")"; # constant folded
a798dbf2 2091 } else {
6e90668e
SM
2092 my $str = $sv->PV;
2093 if ($str =~ /[^ -~]/) { # ASCII
9d2c6865 2094 return single_delim("qq", '"', uninterp escape_str unback $str);
6e90668e
SM
2095 } else {
2096 $str =~ s/\\/\\\\/g;
2097 return single_delim("q", "'", $str);
2098 }
a798dbf2
MB
2099 }
2100}
2101
6e90668e
SM
2102sub pp_const {
2103 my $self = shift;
9d2c6865 2104 my($op, $cx) = @_;
6e90668e
SM
2105# if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting
2106# return $op->sv->PV;
2107# }
2108 return const($op->sv);
2109}
2110
2111sub dq {
2112 my $self = shift;
2113 my $op = shift;
2114 my $type = $op->ppaddr;
2115 if ($type eq "pp_const") {
9d2c6865 2116 return uninterp(escape_str(unback($op->sv->PV)));
6e90668e
SM
2117 } elsif ($type eq "pp_concat") {
2118 return $self->dq($op->first) . $self->dq($op->last);
2119 } elsif ($type eq "pp_uc") {
2120 return '\U' . $self->dq($op->first->sibling) . '\E';
2121 } elsif ($type eq "pp_lc") {
2122 return '\L' . $self->dq($op->first->sibling) . '\E';
2123 } elsif ($type eq "pp_ucfirst") {
2124 return '\u' . $self->dq($op->first->sibling);
2125 } elsif ($type eq "pp_lcfirst") {
2126 return '\l' . $self->dq($op->first->sibling);
2127 } elsif ($type eq "pp_quotemeta") {
2128 return '\Q' . $self->dq($op->first->sibling) . '\E';
2129 } elsif ($type eq "pp_join") {
9d2c6865 2130 return $self->deparse($op->last, 26); # was join($", @ary)
a798dbf2 2131 } else {
9d2c6865 2132 return $self->deparse($op, 26);
6e90668e
SM
2133 }
2134}
2135
2136sub pp_backtick {
2137 my $self = shift;
9d2c6865 2138 my($op, $cx) = @_;
6e90668e
SM
2139 # skip pushmark
2140 return single_delim("qx", '`', $self->dq($op->first->sibling));
2141}
2142
2143sub dquote {
2144 my $self = shift;
2145 my $op = shift;
2146 # skip ex-stringify, pushmark
2147 return single_delim("qq", '"', $self->dq($op->first->sibling));
2148}
2149
2150# OP_STRINGIFY is a listop, but it only ever has one arg (?)
2151sub pp_stringify { dquote(@_) }
2152
2153# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2154# note that tr(from)/to/ is OK, but not tr/from/(to)
2155sub double_delim {
2156 my($from, $to) = @_;
2157 my($succeed, $delim);
2158 if ($from !~ m[/] and $to !~ m[/]) {
2159 return "/$from/$to/";
2160 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2161 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2162 return "$from$to";
2163 } else {
2164 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2165 return "$from$delim$to$delim" if index($to, $delim) == -1;
2166 }
2167 $to =~ s[/][\\/]g;
2168 return "$from/$to/";
2169 }
2170 } else {
2171 for $delim ('/', '"', '#') { # note no '
2172 return "$delim$from$delim$to$delim"
2173 if index($to . $from, $delim) == -1;
2174 }
2175 $from =~ s[/][\\/]g;
2176 $to =~ s[/][\\/]g;
2177 return "/$from/$to/";
2178 }
2179}
2180
2181sub pchr { # ASCII
2182 my($n) = @_;
2183 if ($n == ord '\\') {
2184 return '\\\\';
2185 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2186 return chr($n);
2187 } elsif ($n == ord "\a") {
2188 return '\\a';
2189 } elsif ($n == ord "\b") {
2190 return '\\b';
2191 } elsif ($n == ord "\t") {
2192 return '\\t';
2193 } elsif ($n == ord "\n") {
2194 return '\\n';
2195 } elsif ($n == ord "\e") {
2196 return '\\e';
2197 } elsif ($n == ord "\f") {
2198 return '\\f';
2199 } elsif ($n == ord "\r") {
2200 return '\\r';
2201 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2202 return '\\c' . chr(ord("@") + $n);
2203 } else {
2204# return '\x' . sprintf("%02x", $n);
2205 return '\\' . sprintf("%03o", $n);
2206 }
2207}
2208
2209sub collapse {
2210 my(@chars) = @_;
2211 my($c, $str, $tr);
2212 for ($c = 0; $c < @chars; $c++) {
2213 $tr = $chars[$c];
2214 $str .= pchr($tr);
2215 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2216 $chars[$c + 2] == $tr + 2)
2217 {
2218 for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {}
2219 $str .= "-";
2220 $str .= pchr($chars[$c]);
2221 }
2222 }
2223 return $str;
2224}
2225
2226sub OPpTRANS_SQUASH () { 16 }
2227sub OPpTRANS_DELETE () { 32 }
2228sub OPpTRANS_COMPLEMENT () { 64 }
2229
2230sub pp_trans {
2231 my $self = shift;
9d2c6865 2232 my($op, $cx) = @_;
6e90668e
SM
2233 my(@table) = unpack("s256", $op->pv);
2234 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2235 if ($table[ord "-"] != -1 and
2236 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2237 {
2238 $tr = $table[ord "-"];
2239 $table[ord "-"] = -1;
2240 if ($tr >= 0) {
2241 @from = ord("-");
2242 @to = $tr;
2243 } else { # -2 ==> delete
2244 $delhyphen = 1;
2245 }
2246 }
2247 for ($c = 0; $c < 256; $c++) {
2248 $tr = $table[$c];
2249 if ($tr >= 0) {
2250 push @from, $c; push @to, $tr;
2251 } elsif ($tr == -2) {
2252 push @delfrom, $c;
2253 }
2254 }
2255 my $flags;
2256 @from = (@from, @delfrom);
2257 if ($op->private & OPpTRANS_COMPLEMENT) {
2258 $flags .= "c";
2259 my @newfrom = ();
2260 my %from;
2261 @from{@from} = (1) x @from;
2262 for ($c = 0; $c < 256; $c++) {
2263 push @newfrom, $c unless $from{$c};
2264 }
2265 @from = @newfrom;
2266 }
2267 if ($op->private & OPpTRANS_DELETE) {
2268 $flags .= "d";
2269 } else {
2270 pop @to while $#to and $to[$#to] == $to[$#to -1];
2271 }
2272 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2273 my($from, $to);
2274 $from = collapse(@from);
2275 $to = collapse(@to);
2276 $from .= "-" if $delhyphen;
2277 return "tr" . double_delim($from, $to) . $flags;
2278}
2279
2280# Like dq(), but different
2281sub re_dq {
2282 my $self = shift;
2283 my $op = shift;
2284 my $type = $op->ppaddr;
2285 if ($type eq "pp_const") {
2286 return uninterp($op->sv->PV);
2287 } elsif ($type eq "pp_concat") {
2288 return $self->re_dq($op->first) . $self->re_dq($op->last);
2289 } elsif ($type eq "pp_uc") {
2290 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2291 } elsif ($type eq "pp_lc") {
2292 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2293 } elsif ($type eq "pp_ucfirst") {
2294 return '\u' . $self->re_dq($op->first->sibling);
2295 } elsif ($type eq "pp_lcfirst") {
2296 return '\l' . $self->re_dq($op->first->sibling);
2297 } elsif ($type eq "pp_quotemeta") {
2298 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2299 } elsif ($type eq "pp_join") {
9d2c6865 2300 return $self->deparse($op->last, 26); # was join($", @ary)
6e90668e 2301 } else {
9d2c6865 2302 return $self->deparse($op, 26);
6e90668e
SM
2303 }
2304}
2305
2306sub pp_regcomp {
2307 my $self = shift;
9d2c6865 2308 my($op, $cx) = @_;
6e90668e
SM
2309 my $kid = $op->first;
2310 $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe";
90be192f 2311 $kid = $kid->first if $kid->ppaddr eq "pp_regcreset";
6e90668e
SM
2312 return $self->re_dq($kid);
2313}
2314
2315sub OPp_RUNTIME () { 64 }
2316
2317sub PMf_ONCE () { 0x2 }
2318sub PMf_SKIPWHITE () { 0x10 }
6e90668e
SM
2319sub PMf_CONST () { 0x40 }
2320sub PMf_KEEP () { 0x80 }
2321sub PMf_GLOBAL () { 0x100 }
2322sub PMf_CONTINUE () { 0x200 }
2323sub PMf_EVAL () { 0x400 }
90be192f 2324sub PMf_LOCALE () { 0x800 }
6e90668e
SM
2325sub PMf_MULTILINE () { 0x1000 }
2326sub PMf_SINGLELINE () { 0x2000 }
90be192f 2327sub PMf_FOLD () { 0x4000 }
6e90668e
SM
2328sub PMf_EXTENDED () { 0x8000 }
2329
2330# osmic acid -- see osmium tetroxide
2331
2332my %matchwords;
2333map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2334 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2335 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2336
90be192f 2337sub matchop {
6e90668e 2338 my $self = shift;
90be192f 2339 my($op, $cx, $name, $delim) = @_;
6e90668e 2340 my $kid = $op->first;
9d2c6865 2341 my ($binop, $var, $re) = ("", "", "");
6e90668e 2342 if ($op->flags & OPf_STACKED) {
9d2c6865
SM
2343 $binop = 1;
2344 $var = $self->deparse($kid, 20);
6e90668e
SM
2345 $kid = $kid->sibling;
2346 }
2347 if (null $kid) {
9d2c6865 2348 $re = re_uninterp(escape_str($op->precomp));
6e90668e 2349 } else {
9d2c6865 2350 $re = $self->deparse($kid, 1);
6e90668e
SM
2351 }
2352 my $flags = "";
2353 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2354 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2355 $flags .= "i" if $op->pmflags & PMf_FOLD;
2356 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2357 $flags .= "o" if $op->pmflags & PMf_KEEP;
2358 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2359 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2360 $flags = $matchwords{$flags} if $matchwords{$flags};
2361 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2362 $re =~ s/\?/\\?/g;
9d2c6865
SM
2363 $re = "?$re?";
2364 } else {
90be192f 2365 $re = single_delim($name, $delim, $re);
9d2c6865
SM
2366 }
2367 $re = $re . $flags;
2368 if ($binop) {
2369 return $self->maybe_parens("$var =~ $re", $cx, 20);
2370 } else {
2371 return $re;
6e90668e 2372 }
6e90668e
SM
2373}
2374
90be192f
SM
2375sub pp_match { matchop(@_, "m", "/") }
2376sub pp_pushre { matchop(@_, "m", "/") }
2377sub pp_qr { matchop(@_, "qr", "") }
6e90668e
SM
2378
2379sub pp_split {
2380 my $self = shift;
9d2c6865 2381 my($op, $cx) = @_;
6e90668e
SM
2382 my($kid, @exprs, $ary, $expr);
2383 $kid = $op->first;
2384 if ($ {$kid->pmreplroot}) {
2385 $ary = '@' . $self->gv_name($kid->pmreplroot);
2386 }
2387 for (; !null($kid); $kid = $kid->sibling) {
9d2c6865 2388 push @exprs, $self->deparse($kid, 6);
6e90668e
SM
2389 }
2390 $expr = "split(" . join(", ", @exprs) . ")";
2391 if ($ary) {
9d2c6865 2392 return $self->maybe_parens("$ary = $expr", $cx, 7);
6e90668e
SM
2393 } else {
2394 return $expr;
2395 }
2396}
2397
2398# oxime -- any of various compounds obtained chiefly by the action of
2399# hydroxylamine on aldehydes and ketones and characterized by the
2400# bivalent grouping C=NOH [Webster's Tenth]
2401
2402my %substwords;
2403map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2404 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2405 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2406 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2407
2408sub pp_subst {
2409 my $self = shift;
9d2c6865 2410 my($op, $cx) = @_;
6e90668e 2411 my $kid = $op->first;
9d2c6865 2412 my($binop, $var, $re, $repl) = ("", "", "", "");
6e90668e 2413 if ($op->flags & OPf_STACKED) {
9d2c6865
SM
2414 $binop = 1;
2415 $var = $self->deparse($kid, 20);
6e90668e
SM
2416 $kid = $kid->sibling;
2417 }
2418 my $flags = "";
2419 if (null($op->pmreplroot)) {
2420 $repl = $self->dq($kid);
2421 $kid = $kid->sibling;
2422 } else {
2423 $repl = $op->pmreplroot->first; # skip substcont
2424 while ($repl->ppaddr eq "pp_entereval") {
2425 $repl = $repl->first;
2426 $flags .= "e";
2427 }
9d2c6865 2428 $repl = $self->dq($repl);
6e90668e
SM
2429 }
2430 if (null $kid) {
9d2c6865 2431 $re = re_uninterp(escape_str($op->precomp));
6e90668e 2432 } else {
9d2c6865 2433 $re = $self->deparse($kid, 1);
a798dbf2 2434 }
6e90668e
SM
2435 $flags .= "e" if $op->pmflags & PMf_EVAL;
2436 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2437 $flags .= "i" if $op->pmflags & PMf_FOLD;
2438 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2439 $flags .= "o" if $op->pmflags & PMf_KEEP;
2440 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2441 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2442 $flags = $substwords{$flags} if $substwords{$flags};
9d2c6865
SM
2443 if ($binop) {
2444 return $self->maybe_parens("$var =~ s"
2445 . double_delim($re, $repl) . $flags,
2446 $cx, 20);
2447 } else {
2448 return "s". double_delim($re, $repl) . $flags;
2449 }
a798dbf2
MB
2450}
2451
24521;
f6f9bdb7
SM
2453__END__
2454
2455=head1 NAME
2456
2457B::Deparse - Perl compiler backend to produce perl code
2458
2459=head1 SYNOPSIS
2460
9d2c6865 2461B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-s>I<LETTERS>] I<prog.pl>
f6f9bdb7
SM
2462
2463=head1 DESCRIPTION
2464
2465B::Deparse is a backend module for the Perl compiler that generates
2466perl source code, based on the internal compiled structure that perl
2467itself creates after parsing a program. The output of B::Deparse won't
2468be exactly the same as the original source, since perl doesn't keep
2469track of comments or whitespace, and there isn't a one-to-one
2470correspondence between perl's syntactical constructions and their
9d2c6865
SM
2471compiled form, but it will often be close. When you use the B<-p>
2472option, the output also includes parentheses even when they are not
2473required by precedence, which can make it easy to see if perl is
2474parsing your expressions the way you intended.
f6f9bdb7
SM
2475
2476Please note that this module is mainly new and untested code and is
2477still under development, so it may change in the future.
2478
2479=head1 OPTIONS
2480
9d2c6865
SM
2481As with all compiler backend options, these must follow directly after
2482the '-MO=Deparse', separated by a comma but not any white space.
f6f9bdb7
SM
2483
2484=over 4
2485
9d2c6865
SM
2486=item B<-p>
2487
2488Print extra parentheses. Without this option, B::Deparse includes
2489parentheses in its output only when they are needed, based on the
2490structure of your program. With B<-p>, it uses parentheses (almost)
2491whenever they would be legal. This can be useful if you are used to
2492LISP, or if you want to see how perl parses your input. If you say
2493
2494 if ($var & 0x7f == 65) {print "Gimme an A!"}
2495 print ($which ? $a : $b), "\n";
2496 $name = $ENV{USER} or "Bob";
2497
2498C<B::Deparse,-p> will print
2499
2500 if (($var & 0)) {
2501 print('Gimme an A!')
2502 };
2503 (print(($which ? $a : $b)), '???');
2504 (($name = $ENV{'USER'}) or '???')
2505
2506which probably isn't what you intended (the C<'???'> is a sign that
2507perl optimized away a constant value).
2508
2509=item B<-u>I<PACKAGE>
f6f9bdb7
SM
2510
2511Normally, B::Deparse deparses the main code of a program, all the subs
2512called by the main program (and all the subs called by them,
2513recursively), and any other subs in the main:: package. To include
2514subs in other packages that aren't called directly, such as AUTOLOAD,
2515DESTROY, other subs called automatically by perl, and methods, which
2516aren't resolved to subs until runtime, use the B<-u> option. The
2517argument to B<-u> is the name of a package, and should follow directly
2518after the 'u'. Multiple B<-u> options may be given, separated by
2519commas. Note that unlike some other backends, B::Deparse doesn't
2520(yet) try to guess automatically when B<-u> is needed -- you must
2521invoke it yourself.
2522
9d2c6865
SM
2523=item B<-s>I<LETTERS>
2524
2525Tweak the style of B::Deparse's output. At the moment, only one style
2526option is implemented:
2527
2528=over 4
2529
2530=item B<C>
2531
2532Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2533
2534 if (...) {
2535 ...
2536 } else {
2537 ...
2538 }
2539
2540instead of
2541
2542 if (...) {
2543 ...
2544 }
2545 else {
2546 ...
2547 }
2548
2549The default is not to cuddle.
2550
2551=back
2552
f6f9bdb7
SM
2553=back
2554
2555=head1 BUGS
2556
2557See the 'to do' list at the beginning of the module file.
2558
2559=head1 AUTHOR
2560
2561Stephen McCamant <alias@mcs.com>, based on an earlier version by
2562Malcolm Beattie <mbeattie@sable.ox.ac.uk>.
2563
2564=cut