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