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