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