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