This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add 'clean' target for ext/re
[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;
9d2c6865 1516 $ary = $self->deparse($ary, 1);
6e90668e 1517 if (null $var) {
f6f9bdb7 1518 if ($enter->flags & OPf_SPECIAL) { # thread special var
9d2c6865 1519 $var = $self->pp_threadsv($enter, 1);
f6f9bdb7 1520 } else { # regular my() variable
9d2c6865 1521 $var = $self->pp_padsv($enter, 1);
f6f9bdb7
SM
1522 if ($self->padname_sv($enter->targ)->IVX ==
1523 $kid->first->first->sibling->last->cop_seq)
1524 {
1525 # If the scope of this variable closes at the last
1526 # statement of the loop, it must have been
1527 # declared here.
1528 $var = "my " . $var;
1529 }
6e90668e
SM
1530 }
1531 } elsif ($var->ppaddr eq "pp_rv2gv") {
9d2c6865 1532 $var = $self->pp_rv2sv($var, 1);
6e90668e 1533 } elsif ($var->ppaddr eq "pp_gv") {
9d2c6865 1534 $var = "\$" . $self->deparse($var, 1);
6e90668e 1535 }
9d2c6865 1536 $head = "foreach $var ($ary) ";
6e90668e
SM
1537 $kid = $kid->first->first->sibling; # skip OP_AND and OP_ITER
1538 } elsif ($kid->ppaddr eq "pp_null") { # while/until
1539 $kid = $kid->first;
1540 my $name = {"pp_and" => "while", "pp_or" => "until"}
1541 ->{$kid->ppaddr};
9d2c6865 1542 $head = "$name (" . $self->deparse($kid->first, 1) . ") ";
6e90668e 1543 $kid = $kid->first->sibling;
9d2c6865
SM
1544 } elsif ($kid->ppaddr eq "pp_stub") { # bare and empty
1545 return "{;}"; # {} could be a hashref
6e90668e
SM
1546 }
1547 # The third-to-last kid is the continue block if the pointer used
9d2c6865
SM
1548 # by `next BLOCK' points to its first OP, which happens to be the
1549 # the op_next of the head of the _previous_ statement.
1550 # Unless it's a bare loop, in which case it's last, since there's
1551 # no unstack or extra nextstate.
1552 my($cont, $precont);
1553 if ($bare) {
6e90668e 1554 $cont = $kid->first;
9d2c6865
SM
1555 while (!null($cont->sibling)) {
1556 $precont = $cont;
1557 $cont = $cont->sibling;
1558 }
1559 } else {
1560 $cont = $kid->first;
1561 while (!null($cont->sibling->sibling->sibling)) {
1562 $precont = $cont;
1563 $cont = $cont->sibling;
6e90668e
SM
1564 }
1565 }
9d2c6865
SM
1566# cluck $self->{'curcv'}->GV->NAME unless $precont;
1567 if ($precont and $ {$precont->next} == $ {$enter->nextop}) {
6e90668e 1568 my $state = $kid->first;
9d2c6865 1569 my $cuddle = $self->{'cuddle'};
6e90668e
SM
1570 my($expr, @exprs);
1571 for (; $$state != $$cont; $state = $state->sibling) {
1572 $expr = "";
1573 if (is_state $state) {
9d2c6865 1574 $expr = $self->deparse($state, 0);
6e90668e
SM
1575 $state = $state->sibling;
1576 last if null $kid;
1577 }
9d2c6865 1578 $expr .= $self->deparse($state, 0);
6e90668e
SM
1579 push @exprs, $expr if $expr;
1580 }
1581 $kid = join(";\n", @exprs);
9d2c6865
SM
1582 $cont = $cuddle . "continue {\n\t" .
1583 $self->deparse($cont, 0) . "\n\b}\cK";
6e90668e 1584 } else {
9d2c6865
SM
1585 $cont = "\cK";
1586 $kid = $self->deparse($kid, 0);
6e90668e
SM
1587 }
1588 return $head . "{\n\t" . $kid . "\n\b}" . $cont;
1589}
1590
1591sub pp_leavetry {
1592 my $self = shift;
9d2c6865 1593 return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
6e90668e
SM
1594}
1595
1596sub OP_CONST () { 5 }
1597sub OP_STRINGIFY () { 65 }
a798dbf2
MB
1598
1599sub pp_null {
6e90668e 1600 my $self = shift;
9d2c6865 1601 my($op, $cx) = @_;
6e90668e
SM
1602 if (class($op) eq "OP") {
1603 return "'???'" if $op->targ == OP_CONST; # old value is lost
1604 } elsif ($op->first->ppaddr eq "pp_pushmark") {
9d2c6865 1605 return $self->pp_list($op, $cx);
6e90668e 1606 } elsif ($op->first->ppaddr eq "pp_enter") {
9d2c6865 1607 return $self->pp_leave($op, $cx);
6e90668e
SM
1608 } elsif ($op->targ == OP_STRINGIFY) {
1609 return $self->dquote($op);
1610 } elsif (!null($op->first->sibling) and
1611 $op->first->sibling->ppaddr eq "pp_readline" and
1612 $op->first->sibling->flags & OPf_STACKED) {
9d2c6865
SM
1613 return $self->maybe_parens($self->deparse($op->first, 7) . " = "
1614 . $self->deparse($op->first->sibling, 7),
1615 $cx, 7);
6e90668e
SM
1616 } elsif (!null($op->first->sibling) and
1617 $op->first->sibling->ppaddr eq "pp_trans" and
1618 $op->first->sibling->flags & OPf_STACKED) {
9d2c6865
SM
1619 return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
1620 . $self->deparse($op->first->sibling, 20),
1621 $cx, 20);
6e90668e 1622 } else {
9d2c6865 1623 return $self->deparse($op->first, $cx);
6e90668e 1624 }
a798dbf2
MB
1625}
1626
6e90668e
SM
1627sub padname {
1628 my $self = shift;
1629 my $targ = shift;
1630 my $str = $self->padname_sv($targ)->PV;
1631 return padname_fix($str);
1632}
1633
1634sub padany {
1635 my $self = shift;
1636 my $op = shift;
1637 return substr($self->padname($op->targ), 1); # skip $/@/%
1638}
1639
1640sub pp_padsv {
1641 my $self = shift;
9d2c6865
SM
1642 my($op, $cx) = @_;
1643 return $self->maybe_my($op, $cx, $self->padname($op->targ));
6e90668e
SM
1644}
1645
1646sub pp_padav { pp_padsv(@_) }
1647sub pp_padhv { pp_padsv(@_) }
1648
9d2c6865
SM
1649my @threadsv_names;
1650
1651BEGIN {
1652 @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
1653 "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
1654 "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
1655 "!", "@");
1656}
f6f9bdb7
SM
1657
1658sub pp_threadsv {
1659 my $self = shift;
9d2c6865
SM
1660 my($op, $cx) = @_;
1661 return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
f6f9bdb7
SM
1662}
1663
6e90668e
SM
1664sub pp_gvsv {
1665 my $self = shift;
9d2c6865
SM
1666 my($op, $cx) = @_;
1667 return $self->maybe_local($op, $cx, "\$" . $self->gv_name($op->gv));
6e90668e
SM
1668}
1669
1670sub pp_gv {
1671 my $self = shift;
9d2c6865 1672 my($op, $cx) = @_;
6e90668e
SM
1673 return $self->gv_name($op->gv);
1674}
1675
1676sub pp_aelemfast {
1677 my $self = shift;
9d2c6865 1678 my($op, $cx) = @_;
6e90668e
SM
1679 my $gv = $op->gv;
1680 return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
1681}
1682
1683sub rv2x {
1684 my $self = shift;
9d2c6865 1685 my($op, $cx, $type) = @_;
6e90668e
SM
1686 my $kid = $op->first;
1687 my $scope = is_scope($kid);
9d2c6865 1688 $kid = $self->deparse($kid, 0);
6e90668e
SM
1689 return $type . ($scope ? "{$kid}" : $kid);
1690}
1691
1692sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
1693sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
1694sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
1695
1696# skip rv2av
1697sub pp_av2arylen {
1698 my $self = shift;
9d2c6865 1699 my($op, $cx) = @_;
6e90668e 1700 if ($op->first->ppaddr eq "pp_padav") {
9d2c6865 1701 return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
6e90668e 1702 } else {
9d2c6865 1703 return $self->maybe_local($op, $cx, $self->rv2x($op->first, '$#'));
6e90668e
SM
1704 }
1705}
1706
1707# skip down to the old, ex-rv2cv
9d2c6865 1708sub pp_rv2cv { $_[0]->rv2x($_[1]->first->first->sibling, $_[2], "&") }
6e90668e
SM
1709
1710sub pp_rv2av {
1711 my $self = shift;
9d2c6865 1712 my($op, $cx) = @_;
6e90668e
SM
1713 my $kid = $op->first;
1714 if ($kid->ppaddr eq "pp_const") { # constant list
1715 my $av = $kid->sv;
1716 return "(" . join(", ", map(const($_), $av->ARRAY)) . ")";
1717 } else {
9d2c6865 1718 return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
6e90668e
SM
1719 }
1720 }
1721
1722
1723sub elem {
1724 my $self = shift;
9d2c6865 1725 my ($op, $cx, $left, $right, $padname) = @_;
6e90668e
SM
1726 my($array, $idx) = ($op->first, $op->first->sibling);
1727 unless ($array->ppaddr eq $padname) { # Maybe this has been fixed
1728 $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
1729 }
1730 if ($array->ppaddr eq $padname) {
1731 $array = $self->padany($array);
1732 } elsif (is_scope($array)) { # ${expr}[0]
9d2c6865 1733 $array = "{" . $self->deparse($array, 0) . "}";
6e90668e 1734 } elsif (is_scalar $array) { # $x[0], $$x[0], ...
9d2c6865 1735 $array = $self->deparse($array, 24);
6e90668e
SM
1736 } else {
1737 # $x[20][3]{hi} or expr->[20]
1738 my $arrow;
1739 $arrow = "->" if $array->ppaddr !~ /^pp_[ah]elem$/;
9d2c6865
SM
1740 return $self->deparse($array, 24) . $arrow .
1741 $left . $self->deparse($idx, 1) . $right;
6e90668e 1742 }
9d2c6865 1743 $idx = $self->deparse($idx, 1);
6e90668e
SM
1744 return "\$" . $array . $left . $idx . $right;
1745}
1746
1747sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "pp_padav")) }
1748sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "pp_padhv")) }
1749
1750sub pp_gelem {
1751 my $self = shift;
9d2c6865 1752 my($op, $cx) = @_;
6e90668e
SM
1753 my($glob, $part) = ($op->first, $op->last);
1754 $glob = $glob->first; # skip rv2gv
1755 $glob = $glob->first if $glob->ppaddr eq "pp_rv2gv"; # this one's a bug
9d2c6865
SM
1756 my $scope = is_scope($glob);
1757 $glob = $self->deparse($glob, 0);
1758 $part = $self->deparse($part, 1);
6e90668e
SM
1759 return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
1760}
1761
1762sub slice {
1763 my $self = shift;
9d2c6865 1764 my ($op, $cx, $left, $right, $regname, $padname) = @_;
6e90668e
SM
1765 my $last;
1766 my(@elems, $kid, $array, $list);
1767 if (class($op) eq "LISTOP") {
1768 $last = $op->last;
1769 } else { # ex-hslice inside delete()
1770 for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
1771 $last = $kid;
1772 }
1773 $array = $last;
1774 $array = $array->first
1775 if $array->ppaddr eq $regname or $array->ppaddr eq "pp_null";
1776 if (is_scope($array)) {
9d2c6865 1777 $array = "{" . $self->deparse($array, 0) . "}";
6e90668e
SM
1778 } elsif ($array->ppaddr eq $padname) {
1779 $array = $self->padany($array);
1780 } else {
9d2c6865 1781 $array = $self->deparse($array, 24);
6e90668e
SM
1782 }
1783 $kid = $op->first->sibling; # skip pushmark
1784 if ($kid->ppaddr eq "pp_list") {
1785 $kid = $kid->first->sibling; # skip list, pushmark
1786 for (; !null $kid; $kid = $kid->sibling) {
9d2c6865 1787 push @elems, $self->deparse($kid, 6);
6e90668e
SM
1788 }
1789 $list = join(", ", @elems);
1790 } else {
9d2c6865 1791 $list = $self->deparse($kid, 1);
6e90668e
SM
1792 }
1793 return "\@" . $array . $left . $list . $right;
1794}
1795
1796sub pp_aslice { maybe_local(@_, slice(@_, "[", "]",
1797 "pp_rv2av", "pp_padav")) }
1798sub pp_hslice { maybe_local(@_, slice(@_, "{", "}",
1799 "pp_rv2hv", "pp_padhv")) }
1800
1801sub pp_lslice {
1802 my $self = shift;
9d2c6865 1803 my($op, $cx) = @_;
6e90668e
SM
1804 my $idx = $op->first;
1805 my $list = $op->last;
1806 my(@elems, $kid);
9d2c6865
SM
1807 $list = $self->deparse($list, 1);
1808 $idx = $self->deparse($idx, 1);
1809 return "($list)" . "[$idx]";
6e90668e
SM
1810}
1811
1812sub OPpENTERSUB_AMPER () { 8 }
1813
1814sub OPf_WANT () { 3 }
1815sub OPf_WANT_VOID () { 1 }
1816sub OPf_WANT_SCALAR () { 2 }
1817sub OPf_WANT_LIST () { 2 }
1818
1819sub want_scalar {
1820 my $op = shift;
1821 return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
1822}
1823
1824sub pp_entersub {
1825 my $self = shift;
9d2c6865 1826 my($op, $cx) = @_;
6e90668e
SM
1827 my $prefix = "";
1828 my $amper = "";
1829 my $proto = undef;
9d2c6865 1830 my $simple = 0;
6e90668e 1831 my($kid, $args, @exprs);
9d2c6865 1832 if (not null $op->first->sibling) { # method
6e90668e 1833 $kid = $op->first->sibling; # skip pushmark
9d2c6865 1834 my $obj = $self->deparse($kid, 24);
6e90668e
SM
1835 $kid = $kid->sibling;
1836 for (; not null $kid->sibling; $kid = $kid->sibling) {
9d2c6865 1837 push @exprs, $self->deparse($kid, 6);
6e90668e
SM
1838 }
1839 my $meth = $kid->first;
1840 if ($meth->ppaddr eq "pp_const") {
1841 $meth = $meth->sv->PV; # needs to be bare
1842 } else {
9d2c6865 1843 $meth = $self->deparse($meth, 1);
6e90668e 1844 }
6e90668e
SM
1845 $args = join(", ", @exprs);
1846 $kid = $obj . "->" . $meth;
9d2c6865
SM
1847 if ($args) {
1848 return $kid . "(" . $args . ")"; # parens mandatory
6e90668e 1849 } else {
9d2c6865 1850 return $kid; # toke.c fakes parens
6e90668e 1851 }
9d2c6865
SM
1852 }
1853 # else, not a method
1854 if ($op->flags & OPf_SPECIAL) {
1855 $prefix = "do ";
1856 } elsif ($op->private & OPpENTERSUB_AMPER) {
1857 $amper = "&";
1858 }
1859 $kid = $op->first;
1860 $kid = $kid->first->sibling; # skip ex-list, pushmark
1861 for (; not null $kid->sibling; $kid = $kid->sibling) {
1862 push @exprs, $kid;
1863 }
1864 if (is_scope($kid)) {
1865 $amper = "&";
1866 $kid = "{" . $self->deparse($kid, 0) . "}";
1867 } elsif ($kid->first->ppaddr eq "pp_gv") {
1868 my $gv = $kid->first->gv;
1869 if (class($gv->CV) ne "SPECIAL") {
1870 $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
1871 }
1872 $simple = 1;
1873 $kid = $self->deparse($kid, 24);
1874 } elsif (is_scalar $kid->first) {
1875 $amper = "&";
1876 $kid = $self->deparse($kid, 24);
1877 } else {
1878 $prefix = "";
1879 $kid = $self->deparse($kid, 24) . "->";
1880 }
1881 if (defined $proto and not $amper) {
1882 my($arg, $real);
1883 my $doneok = 0;
1884 my @args = @exprs;
1885 my @reals;
1886 $proto =~ s/([^\\]|^)([@%])(.*)$/$1$2/;
1887 while ($proto) {
1888 $proto =~ s/^ *([\\]?[\$\@&%*]|;)//;
1889 my $chr = $1;
1890 if ($chr eq "") {
1891 undef $proto if @args;
1892 } elsif ($chr eq ";") {
1893 $doneok = 1;
1894 } elsif ($chr eq "@" or $chr eq "%") {
1895 push @reals, map($self->deparse($_, 6), @args);
1896 @args = ();
1897 } else {
1898 $arg = shift @args;
1899 undef $proto, last unless $arg;
1900 if ($chr eq "\$") {
1901 if (want_scalar $arg) {
1902 push @reals, $self->deparse($arg, 6);
1903 } else {
1904 undef $proto;
1905 }
1906 } elsif ($chr eq "&") {
1907 if ($arg->ppaddr =~ /pp_(s?refgen|undef)/) {
1908 push @reals, $self->deparse($arg, 6);
1909 } else {
1910 undef $proto;
1911 }
1912 } elsif ($chr eq "*") {
1913 if ($arg->ppaddr =~ /^pp_s?refgen$/
1914 and $arg->first->first->ppaddr eq "pp_rv2gv")
1915 {
1916 $real = $arg->first->first; # skip refgen, null
1917 if ($real->first->ppaddr eq "pp_gv") {
1918 push @reals, $self->deparse($real, 6);
6e90668e 1919 } else {
9d2c6865 1920 push @reals, $self->deparse($real->first, 6);
6e90668e 1921 }
9d2c6865
SM
1922 } else {
1923 undef $proto;
1924 }
1925 } elsif (substr($chr, 0, 1) eq "\\") {
1926 $chr = substr($chr, 1);
1927 if ($arg->ppaddr =~ /^pp_s?refgen$/ and
1928 !null($real = $arg->first) and
1929 ($chr eq "\$" && is_scalar($real->first)
1930 or ($chr eq "\@"
1931 && $real->first->sibling->ppaddr
1932 =~ /^pp_(rv2|pad)av$/)
1933 or ($chr eq "%"
1934 && $real->first->sibling->ppaddr
1935 =~ /^pp_(rv2|pad)hv$/)
1936 #or ($chr eq "&" # This doesn't work
1937 # && $real->first->ppaddr eq "pp_rv2cv")
1938 or ($chr eq "*"
1939 && $real->first->ppaddr eq "pp_rv2gv")))
1940 {
1941 push @reals, $self->deparse($real, 6);
1942 } else {
1943 undef $proto;
6e90668e
SM
1944 }
1945 }
1946 }
6e90668e 1947 }
9d2c6865
SM
1948 undef $proto if $proto and !$doneok;
1949 undef $proto if @args;
1950 $args = join(", ", @reals);
1951 $amper = "";
1952 unless (defined $proto) {
1953 $amper = "&";
1954 $args = join(", ", map($self->deparse($_, 6), @exprs));
1955 }
1956 } else {
1957 $args = join(", ", map($self->deparse($_, 6), @exprs));
6e90668e 1958 }
9d2c6865
SM
1959 if ($prefix or $amper) {
1960 if ($op->flags & OPf_STACKED) {
1961 return $prefix . $amper . $kid . "(" . $args . ")";
1962 } else {
1963 return $prefix . $amper. $kid;
1964 }
6e90668e 1965 } else {
9d2c6865
SM
1966 if (defined $proto and $proto eq "") {
1967 return $kid;
1968 } elsif ($proto eq "\$") {
1969 return $self->maybe_parens_func($kid, $args, $cx, 16);
1970 } elsif ($proto or $simple) {
1971 return $self->maybe_parens_func($kid, $args, $cx, 5);
1972 } else {
1973 return "$kid(" . $args . ")";
1974 }
6e90668e
SM
1975 }
1976}
1977
1978sub pp_enterwrite { unop(@_, "write") }
1979
1980# escape things that cause interpolation in double quotes,
1981# but not character escapes
1982sub uninterp {
1983 my($str) = @_;
9d2c6865
SM
1984 $str =~ s/(^|[^\\])([\$\@]|\\[uUlLQE])/$1\\$2/g;
1985 return $str;
1986}
1987
1988# the same, but treat $|, $), and $ at the end of the string differently
1989sub re_uninterp {
1990 my($str) = @_;
1991 $str =~ s/(^|[^\\])(\@|\\[uUlLQE])/$1\\$2/g;
1992 $str =~ s/(^|[^\\])(\$[^)|])/$1\\$2/g;
6e90668e
SM
1993 return $str;
1994}
1995
1996# character escapes, but not delimiters that might need to be escaped
1997sub escape_str { # ASCII
1998 my($str) = @_;
6e90668e
SM
1999 $str =~ s/\a/\\a/g;
2000# $str =~ s/\cH/\\b/g; # \b means someting different in a regex
2001 $str =~ s/\t/\\t/g;
2002 $str =~ s/\n/\\n/g;
2003 $str =~ s/\e/\\e/g;
2004 $str =~ s/\f/\\f/g;
2005 $str =~ s/\r/\\r/g;
2006 $str =~ s/([\cA-\cZ])/'\\c' . chr(ord('@') + ord($1))/ge;
2007 $str =~ s/([\0\033-\037\177-\377])/'\\' . sprintf("%03o", ord($1))/ge;
2008 return $str;
2009}
2010
9d2c6865
SM
2011# Don't do this for regexen
2012sub unback {
2013 my($str) = @_;
2014 $str =~ s/\\/\\\\/g;
2015 return $str;
2016}
2017
6e90668e
SM
2018sub balanced_delim {
2019 my($str) = @_;
2020 my @str = split //, $str;
2021 my($ar, $open, $close, $fail, $c, $cnt);
2022 for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
2023 ($open, $close) = @$ar;
2024 $fail = 0; $cnt = 0;
2025 for $c (@str) {
2026 if ($c eq $open) {
2027 $cnt++;
2028 } elsif ($c eq $close) {
2029 $cnt--;
2030 if ($cnt < 0) {
2031 $fail = 1;
2032 last;
2033 }
2034 }
2035 }
2036 $fail = 1 if $cnt != 0;
2037 return ($open, "$open$str$close") if not $fail;
2038 }
2039 return ("", $str);
2040}
2041
2042sub single_delim {
2043 my($q, $default, $str) = @_;
2044 return "$default$str$default" if index($str, $default) == -1;
2045 my($succeed, $delim);
2046 ($succeed, $str) = balanced_delim($str);
2047 return "$q$str" if $succeed;
2048 for $delim ('/', '"', '#') {
2049 return "$q$delim" . $str . $delim if index($str, $delim) == -1;
2050 }
2051 $str =~ s/$default/\\$default/g;
2052 return "$default$str$default";
2053}
2054
2055sub SVf_IOK () {0x10000}
2056sub SVf_NOK () {0x20000}
2057sub SVf_ROK () {0x80000}
2058
2059sub const {
2060 my $sv = shift;
2061 if (class($sv) eq "SPECIAL") {
9d2c6865 2062 return ('undef', '1', '0')[$$sv-1];
6e90668e 2063 } elsif ($sv->FLAGS & SVf_IOK) {
a798dbf2 2064 return $sv->IV;
6e90668e 2065 } elsif ($sv->FLAGS & SVf_NOK) {
a798dbf2 2066 return $sv->NV;
6e90668e
SM
2067 } elsif ($sv->FLAGS & SVf_ROK) {
2068 return "\\(" . const($sv->RV) . ")"; # constant folded
a798dbf2 2069 } else {
6e90668e
SM
2070 my $str = $sv->PV;
2071 if ($str =~ /[^ -~]/) { # ASCII
9d2c6865 2072 return single_delim("qq", '"', uninterp escape_str unback $str);
6e90668e
SM
2073 } else {
2074 $str =~ s/\\/\\\\/g;
2075 return single_delim("q", "'", $str);
2076 }
a798dbf2
MB
2077 }
2078}
2079
6e90668e
SM
2080sub pp_const {
2081 my $self = shift;
9d2c6865 2082 my($op, $cx) = @_;
6e90668e
SM
2083# if ($op->private & OPp_CONST_BARE) { # trouble with `=>' autoquoting
2084# return $op->sv->PV;
2085# }
2086 return const($op->sv);
2087}
2088
2089sub dq {
2090 my $self = shift;
2091 my $op = shift;
2092 my $type = $op->ppaddr;
2093 if ($type eq "pp_const") {
9d2c6865 2094 return uninterp(escape_str(unback($op->sv->PV)));
6e90668e
SM
2095 } elsif ($type eq "pp_concat") {
2096 return $self->dq($op->first) . $self->dq($op->last);
2097 } elsif ($type eq "pp_uc") {
2098 return '\U' . $self->dq($op->first->sibling) . '\E';
2099 } elsif ($type eq "pp_lc") {
2100 return '\L' . $self->dq($op->first->sibling) . '\E';
2101 } elsif ($type eq "pp_ucfirst") {
2102 return '\u' . $self->dq($op->first->sibling);
2103 } elsif ($type eq "pp_lcfirst") {
2104 return '\l' . $self->dq($op->first->sibling);
2105 } elsif ($type eq "pp_quotemeta") {
2106 return '\Q' . $self->dq($op->first->sibling) . '\E';
2107 } elsif ($type eq "pp_join") {
9d2c6865 2108 return $self->deparse($op->last, 26); # was join($", @ary)
a798dbf2 2109 } else {
9d2c6865 2110 return $self->deparse($op, 26);
6e90668e
SM
2111 }
2112}
2113
2114sub pp_backtick {
2115 my $self = shift;
9d2c6865 2116 my($op, $cx) = @_;
6e90668e
SM
2117 # skip pushmark
2118 return single_delim("qx", '`', $self->dq($op->first->sibling));
2119}
2120
2121sub dquote {
2122 my $self = shift;
2123 my $op = shift;
2124 # skip ex-stringify, pushmark
2125 return single_delim("qq", '"', $self->dq($op->first->sibling));
2126}
2127
2128# OP_STRINGIFY is a listop, but it only ever has one arg (?)
2129sub pp_stringify { dquote(@_) }
2130
2131# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
2132# note that tr(from)/to/ is OK, but not tr/from/(to)
2133sub double_delim {
2134 my($from, $to) = @_;
2135 my($succeed, $delim);
2136 if ($from !~ m[/] and $to !~ m[/]) {
2137 return "/$from/$to/";
2138 } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
2139 if (($succeed, $to) = balanced_delim($to) and $succeed) {
2140 return "$from$to";
2141 } else {
2142 for $delim ('/', '"', '#') { # note no `'' -- s''' is special
2143 return "$from$delim$to$delim" if index($to, $delim) == -1;
2144 }
2145 $to =~ s[/][\\/]g;
2146 return "$from/$to/";
2147 }
2148 } else {
2149 for $delim ('/', '"', '#') { # note no '
2150 return "$delim$from$delim$to$delim"
2151 if index($to . $from, $delim) == -1;
2152 }
2153 $from =~ s[/][\\/]g;
2154 $to =~ s[/][\\/]g;
2155 return "/$from/$to/";
2156 }
2157}
2158
2159sub pchr { # ASCII
2160 my($n) = @_;
2161 if ($n == ord '\\') {
2162 return '\\\\';
2163 } elsif ($n >= ord(' ') and $n <= ord('~')) {
2164 return chr($n);
2165 } elsif ($n == ord "\a") {
2166 return '\\a';
2167 } elsif ($n == ord "\b") {
2168 return '\\b';
2169 } elsif ($n == ord "\t") {
2170 return '\\t';
2171 } elsif ($n == ord "\n") {
2172 return '\\n';
2173 } elsif ($n == ord "\e") {
2174 return '\\e';
2175 } elsif ($n == ord "\f") {
2176 return '\\f';
2177 } elsif ($n == ord "\r") {
2178 return '\\r';
2179 } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
2180 return '\\c' . chr(ord("@") + $n);
2181 } else {
2182# return '\x' . sprintf("%02x", $n);
2183 return '\\' . sprintf("%03o", $n);
2184 }
2185}
2186
2187sub collapse {
2188 my(@chars) = @_;
2189 my($c, $str, $tr);
2190 for ($c = 0; $c < @chars; $c++) {
2191 $tr = $chars[$c];
2192 $str .= pchr($tr);
2193 if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
2194 $chars[$c + 2] == $tr + 2)
2195 {
2196 for (; $c <= $#chars and $chars[$c + 1] == $chars[$c] + 1; $c++) {}
2197 $str .= "-";
2198 $str .= pchr($chars[$c]);
2199 }
2200 }
2201 return $str;
2202}
2203
2204sub OPpTRANS_SQUASH () { 16 }
2205sub OPpTRANS_DELETE () { 32 }
2206sub OPpTRANS_COMPLEMENT () { 64 }
2207
2208sub pp_trans {
2209 my $self = shift;
9d2c6865 2210 my($op, $cx) = @_;
6e90668e
SM
2211 my(@table) = unpack("s256", $op->pv);
2212 my($c, $tr, @from, @to, @delfrom, $delhyphen);
2213 if ($table[ord "-"] != -1 and
2214 $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
2215 {
2216 $tr = $table[ord "-"];
2217 $table[ord "-"] = -1;
2218 if ($tr >= 0) {
2219 @from = ord("-");
2220 @to = $tr;
2221 } else { # -2 ==> delete
2222 $delhyphen = 1;
2223 }
2224 }
2225 for ($c = 0; $c < 256; $c++) {
2226 $tr = $table[$c];
2227 if ($tr >= 0) {
2228 push @from, $c; push @to, $tr;
2229 } elsif ($tr == -2) {
2230 push @delfrom, $c;
2231 }
2232 }
2233 my $flags;
2234 @from = (@from, @delfrom);
2235 if ($op->private & OPpTRANS_COMPLEMENT) {
2236 $flags .= "c";
2237 my @newfrom = ();
2238 my %from;
2239 @from{@from} = (1) x @from;
2240 for ($c = 0; $c < 256; $c++) {
2241 push @newfrom, $c unless $from{$c};
2242 }
2243 @from = @newfrom;
2244 }
2245 if ($op->private & OPpTRANS_DELETE) {
2246 $flags .= "d";
2247 } else {
2248 pop @to while $#to and $to[$#to] == $to[$#to -1];
2249 }
2250 $flags .= "s" if $op->private & OPpTRANS_SQUASH;
2251 my($from, $to);
2252 $from = collapse(@from);
2253 $to = collapse(@to);
2254 $from .= "-" if $delhyphen;
2255 return "tr" . double_delim($from, $to) . $flags;
2256}
2257
2258# Like dq(), but different
2259sub re_dq {
2260 my $self = shift;
2261 my $op = shift;
2262 my $type = $op->ppaddr;
2263 if ($type eq "pp_const") {
2264 return uninterp($op->sv->PV);
2265 } elsif ($type eq "pp_concat") {
2266 return $self->re_dq($op->first) . $self->re_dq($op->last);
2267 } elsif ($type eq "pp_uc") {
2268 return '\U' . $self->re_dq($op->first->sibling) . '\E';
2269 } elsif ($type eq "pp_lc") {
2270 return '\L' . $self->re_dq($op->first->sibling) . '\E';
2271 } elsif ($type eq "pp_ucfirst") {
2272 return '\u' . $self->re_dq($op->first->sibling);
2273 } elsif ($type eq "pp_lcfirst") {
2274 return '\l' . $self->re_dq($op->first->sibling);
2275 } elsif ($type eq "pp_quotemeta") {
2276 return '\Q' . $self->re_dq($op->first->sibling) . '\E';
2277 } elsif ($type eq "pp_join") {
9d2c6865 2278 return $self->deparse($op->last, 26); # was join($", @ary)
6e90668e 2279 } else {
9d2c6865 2280 return $self->deparse($op, 26);
6e90668e
SM
2281 }
2282}
2283
2284sub pp_regcomp {
2285 my $self = shift;
9d2c6865 2286 my($op, $cx) = @_;
6e90668e
SM
2287 my $kid = $op->first;
2288 $kid = $kid->first if $kid->ppaddr eq "pp_regcmaybe";
2289 return $self->re_dq($kid);
2290}
2291
2292sub OPp_RUNTIME () { 64 }
2293
2294sub PMf_ONCE () { 0x2 }
2295sub PMf_SKIPWHITE () { 0x10 }
2296sub PMf_FOLD () { 0x20 }
2297sub PMf_CONST () { 0x40 }
2298sub PMf_KEEP () { 0x80 }
2299sub PMf_GLOBAL () { 0x100 }
2300sub PMf_CONTINUE () { 0x200 }
2301sub PMf_EVAL () { 0x400 }
2302sub PMf_MULTILINE () { 0x1000 }
2303sub PMf_SINGLELINE () { 0x2000 }
2304sub PMf_LOCALE () { 0x4000 }
2305sub PMf_EXTENDED () { 0x8000 }
2306
2307# osmic acid -- see osmium tetroxide
2308
2309my %matchwords;
2310map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
2311 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
2312 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
2313
2314sub pp_match {
2315 my $self = shift;
9d2c6865 2316 my($op, $cx) = @_;
6e90668e 2317 my $kid = $op->first;
9d2c6865 2318 my ($binop, $var, $re) = ("", "", "");
6e90668e 2319 if ($op->flags & OPf_STACKED) {
9d2c6865
SM
2320 $binop = 1;
2321 $var = $self->deparse($kid, 20);
6e90668e
SM
2322 $kid = $kid->sibling;
2323 }
2324 if (null $kid) {
9d2c6865 2325 $re = re_uninterp(escape_str($op->precomp));
6e90668e 2326 } else {
9d2c6865 2327 $re = $self->deparse($kid, 1);
6e90668e
SM
2328 }
2329 my $flags = "";
2330 $flags .= "c" if $op->pmflags & PMf_CONTINUE;
2331 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2332 $flags .= "i" if $op->pmflags & PMf_FOLD;
2333 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2334 $flags .= "o" if $op->pmflags & PMf_KEEP;
2335 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2336 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2337 $flags = $matchwords{$flags} if $matchwords{$flags};
2338 if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
2339 $re =~ s/\?/\\?/g;
9d2c6865
SM
2340 $re = "?$re?";
2341 } else {
2342 $re = single_delim("m", "/", $re);
2343 }
2344 $re = $re . $flags;
2345 if ($binop) {
2346 return $self->maybe_parens("$var =~ $re", $cx, 20);
2347 } else {
2348 return $re;
6e90668e 2349 }
6e90668e
SM
2350}
2351
2352sub pp_pushre { pp_match(@_) }
2353
2354sub pp_split {
2355 my $self = shift;
9d2c6865 2356 my($op, $cx) = @_;
6e90668e
SM
2357 my($kid, @exprs, $ary, $expr);
2358 $kid = $op->first;
2359 if ($ {$kid->pmreplroot}) {
2360 $ary = '@' . $self->gv_name($kid->pmreplroot);
2361 }
2362 for (; !null($kid); $kid = $kid->sibling) {
9d2c6865 2363 push @exprs, $self->deparse($kid, 6);
6e90668e
SM
2364 }
2365 $expr = "split(" . join(", ", @exprs) . ")";
2366 if ($ary) {
9d2c6865 2367 return $self->maybe_parens("$ary = $expr", $cx, 7);
6e90668e
SM
2368 } else {
2369 return $expr;
2370 }
2371}
2372
2373# oxime -- any of various compounds obtained chiefly by the action of
2374# hydroxylamine on aldehydes and ketones and characterized by the
2375# bivalent grouping C=NOH [Webster's Tenth]
2376
2377my %substwords;
2378map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
2379 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
2380 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
2381 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
2382
2383sub pp_subst {
2384 my $self = shift;
9d2c6865 2385 my($op, $cx) = @_;
6e90668e 2386 my $kid = $op->first;
9d2c6865 2387 my($binop, $var, $re, $repl) = ("", "", "", "");
6e90668e 2388 if ($op->flags & OPf_STACKED) {
9d2c6865
SM
2389 $binop = 1;
2390 $var = $self->deparse($kid, 20);
6e90668e
SM
2391 $kid = $kid->sibling;
2392 }
2393 my $flags = "";
2394 if (null($op->pmreplroot)) {
2395 $repl = $self->dq($kid);
2396 $kid = $kid->sibling;
2397 } else {
2398 $repl = $op->pmreplroot->first; # skip substcont
2399 while ($repl->ppaddr eq "pp_entereval") {
2400 $repl = $repl->first;
2401 $flags .= "e";
2402 }
9d2c6865 2403 $repl = $self->dq($repl);
6e90668e
SM
2404 }
2405 if (null $kid) {
9d2c6865 2406 $re = re_uninterp(escape_str($op->precomp));
6e90668e 2407 } else {
9d2c6865 2408 $re = $self->deparse($kid, 1);
a798dbf2 2409 }
6e90668e
SM
2410 $flags .= "e" if $op->pmflags & PMf_EVAL;
2411 $flags .= "g" if $op->pmflags & PMf_GLOBAL;
2412 $flags .= "i" if $op->pmflags & PMf_FOLD;
2413 $flags .= "m" if $op->pmflags & PMf_MULTILINE;
2414 $flags .= "o" if $op->pmflags & PMf_KEEP;
2415 $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
2416 $flags .= "x" if $op->pmflags & PMf_EXTENDED;
2417 $flags = $substwords{$flags} if $substwords{$flags};
9d2c6865
SM
2418 if ($binop) {
2419 return $self->maybe_parens("$var =~ s"
2420 . double_delim($re, $repl) . $flags,
2421 $cx, 20);
2422 } else {
2423 return "s". double_delim($re, $repl) . $flags;
2424 }
a798dbf2
MB
2425}
2426
24271;
f6f9bdb7
SM
2428__END__
2429
2430=head1 NAME
2431
2432B::Deparse - Perl compiler backend to produce perl code
2433
2434=head1 SYNOPSIS
2435
9d2c6865 2436B<perl> B<-MO=Deparse>[B<,-u>I<PACKAGE>][B<,-p>][B<,-s>I<LETTERS>] I<prog.pl>
f6f9bdb7
SM
2437
2438=head1 DESCRIPTION
2439
2440B::Deparse is a backend module for the Perl compiler that generates
2441perl source code, based on the internal compiled structure that perl
2442itself creates after parsing a program. The output of B::Deparse won't
2443be exactly the same as the original source, since perl doesn't keep
2444track of comments or whitespace, and there isn't a one-to-one
2445correspondence between perl's syntactical constructions and their
9d2c6865
SM
2446compiled form, but it will often be close. When you use the B<-p>
2447option, the output also includes parentheses even when they are not
2448required by precedence, which can make it easy to see if perl is
2449parsing your expressions the way you intended.
f6f9bdb7
SM
2450
2451Please note that this module is mainly new and untested code and is
2452still under development, so it may change in the future.
2453
2454=head1 OPTIONS
2455
9d2c6865
SM
2456As with all compiler backend options, these must follow directly after
2457the '-MO=Deparse', separated by a comma but not any white space.
f6f9bdb7
SM
2458
2459=over 4
2460
9d2c6865
SM
2461=item B<-p>
2462
2463Print extra parentheses. Without this option, B::Deparse includes
2464parentheses in its output only when they are needed, based on the
2465structure of your program. With B<-p>, it uses parentheses (almost)
2466whenever they would be legal. This can be useful if you are used to
2467LISP, or if you want to see how perl parses your input. If you say
2468
2469 if ($var & 0x7f == 65) {print "Gimme an A!"}
2470 print ($which ? $a : $b), "\n";
2471 $name = $ENV{USER} or "Bob";
2472
2473C<B::Deparse,-p> will print
2474
2475 if (($var & 0)) {
2476 print('Gimme an A!')
2477 };
2478 (print(($which ? $a : $b)), '???');
2479 (($name = $ENV{'USER'}) or '???')
2480
2481which probably isn't what you intended (the C<'???'> is a sign that
2482perl optimized away a constant value).
2483
2484=item B<-u>I<PACKAGE>
f6f9bdb7
SM
2485
2486Normally, B::Deparse deparses the main code of a program, all the subs
2487called by the main program (and all the subs called by them,
2488recursively), and any other subs in the main:: package. To include
2489subs in other packages that aren't called directly, such as AUTOLOAD,
2490DESTROY, other subs called automatically by perl, and methods, which
2491aren't resolved to subs until runtime, use the B<-u> option. The
2492argument to B<-u> is the name of a package, and should follow directly
2493after the 'u'. Multiple B<-u> options may be given, separated by
2494commas. Note that unlike some other backends, B::Deparse doesn't
2495(yet) try to guess automatically when B<-u> is needed -- you must
2496invoke it yourself.
2497
9d2c6865
SM
2498=item B<-s>I<LETTERS>
2499
2500Tweak the style of B::Deparse's output. At the moment, only one style
2501option is implemented:
2502
2503=over 4
2504
2505=item B<C>
2506
2507Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
2508
2509 if (...) {
2510 ...
2511 } else {
2512 ...
2513 }
2514
2515instead of
2516
2517 if (...) {
2518 ...
2519 }
2520 else {
2521 ...
2522 }
2523
2524The default is not to cuddle.
2525
2526=back
2527
f6f9bdb7
SM
2528=back
2529
2530=head1 BUGS
2531
2532See the 'to do' list at the beginning of the module file.
2533
2534=head1 AUTHOR
2535
2536Stephen McCamant <alias@mcs.com>, based on an earlier version by
2537Malcolm Beattie <mbeattie@sable.ox.ac.uk>.
2538
2539=cut