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