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