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