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