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