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