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